add missing libs and update settings to new versions
This commit is contained in:
521
lisp/citeproc/citeproc-biblatex.el
Normal file
521
lisp/citeproc/citeproc-biblatex.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
<https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/Citeproc/BibTeX.hs>
|
||||
Many thanks to him.
|
||||
|
||||
Note: in the code, var names starting with ~ refer to values of
|
||||
biblatex variables in B."
|
||||
(let* ((b (cl-remove-if (lambda (x) (equal "" (cdr x))) b))
|
||||
(b (mapcar (lambda (x) (cons (intern (downcase (car x))) (cdr x))) b))
|
||||
(~type (intern (downcase (alist-get '=type= b))))
|
||||
(~entrysubtype (alist-get 'entrysubtype b))
|
||||
(type (citeproc-blt--to-csl-type ~type ~entrysubtype))
|
||||
(is-article (memq ~type citeproc-blt-article-types))
|
||||
(is-periodical (eq ~type 'periodical))
|
||||
(is-chapter-like (memq ~type citeproc-blt-chapter-types))
|
||||
(~langid (alist-get 'langid b))
|
||||
(sent-case (or (member ~langid citeproc-blt--titlecase-langids)
|
||||
(and (null ~langid) (not no-sentcase-wo-langid))))
|
||||
(with-nocase (not omit-nocase))
|
||||
result)
|
||||
;; language
|
||||
(when ~langid
|
||||
(push (cons 'language (cdr (assoc ~langid citeproc-blt--langid-to-lang-alist)))
|
||||
result))
|
||||
;; set type and genre
|
||||
(push (cons 'type type) result)
|
||||
(when-let ((~reftype (alist-get 'type b)))
|
||||
(push (cons 'genre (or (assoc-default ~reftype citeproc-blt-reftype-to-genre)
|
||||
(citeproc-bt--to-csl ~reftype)))
|
||||
result))
|
||||
;; 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
|
||||
481
lisp/citeproc/citeproc-bibtex.el
Normal file
481
lisp/citeproc/citeproc-bibtex.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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 "<span class=\"nocase\">")
|
||||
(when with-nocase "</span>"))
|
||||
(citeproc-s-replace-all-seq it '(("\n" . " ") ("~" . " ") ("--" . "–")))
|
||||
(s-trim it))
|
||||
s))
|
||||
|
||||
(defun citeproc-bt--to-csl-names (n)
|
||||
"Return a CSL version of BibTeX names field N."
|
||||
(let ((name-fields (s-split "\\band\\b" n)))
|
||||
(mapcar
|
||||
(lambda (x)
|
||||
(let ((trimmed (s-trim x)))
|
||||
(cond
|
||||
((string= trimmed "") '((family . "")))
|
||||
;; Presence of equal sign signals extended specification.
|
||||
((string-match "=" trimmed) (citeproc-bt--ext-desc-to-csl-name trimmed))
|
||||
;; Brackets indicate corporate entities without name parts.
|
||||
((and (string= "{" (substring trimmed 0 1))
|
||||
(string= "}" (substring trimmed -1)))
|
||||
`((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 <bzg@gnu.org>, Carsten Dominik <carsten dot dominik
|
||||
;; at gmail dot com> and Eric Schulte <schulte dot eric at gmail dot com>.
|
||||
;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
|
||||
(defun citeproc-bt-from-org-headline (&optional itemids)
|
||||
"Return a (KEY . BIBTEX-ENTRY) pair from the headline at point.
|
||||
The returned BibTeX entry has the same form as produced by
|
||||
`bibtex-parse-entry'. Return nil if the headline has no
|
||||
associated bibtex data. If optional ITEMIDS is given then also
|
||||
return nil if the entry's key is not in ITEMIDS."
|
||||
(letrec ((val (lambda (key lst) (cdr (assoc key lst))))
|
||||
(to (lambda (string) (intern (concat ":" string))))
|
||||
(from (lambda (key) (substring (symbol-name key) 1)))
|
||||
(flatten (lambda (&rest lsts)
|
||||
(apply #'append (mapcar
|
||||
(lambda (e)
|
||||
(if (listp e) (apply flatten e) (list e)))
|
||||
lsts))))
|
||||
(id (org-bibtex-get org-bibtex-key-property))
|
||||
(type (org-bibtex-get org-bibtex-type-property-name)))
|
||||
(when (and type (or (null itemids) (member id itemids)))
|
||||
`(,id .
|
||||
(("=type=" . ,type)
|
||||
,@(remove
|
||||
nil
|
||||
(if (and org-bibtex-export-arbitrary-fields
|
||||
org-bibtex-prefix)
|
||||
(mapcar
|
||||
(lambda (kv)
|
||||
(let ((key (car kv)) (val0 (cdr kv)))
|
||||
(when (and
|
||||
(string-match org-bibtex-prefix key)
|
||||
(not (string=
|
||||
(downcase (concat org-bibtex-prefix
|
||||
org-bibtex-type-property-name))
|
||||
(downcase key))))
|
||||
(cons (downcase (replace-regexp-in-string
|
||||
org-bibtex-prefix "" key))
|
||||
val0))))
|
||||
(org-entry-properties nil 'standard))
|
||||
(mapcar
|
||||
(lambda (field)
|
||||
(let ((value (or (org-bibtex-get (funcall from field))
|
||||
(and (eq :title field)
|
||||
(nth 4 (org-heading-components))))))
|
||||
(when value (cons (funcall from field) value))))
|
||||
(funcall flatten
|
||||
(funcall val :required (funcall val (funcall to type) org-bibtex-types))
|
||||
(funcall val :optional (funcall val (funcall to type) org-bibtex-types)))))))))))
|
||||
|
||||
(provide 'citeproc-bibtex)
|
||||
|
||||
;;; citeproc-bibtex.el ends here
|
||||
118
lisp/citeproc/citeproc-choose.el
Normal file
118
lisp/citeproc/citeproc-choose.el
Normal file
@@ -0,0 +1,118 @@
|
||||
;; citeproc-choose.el --- conditionally rendered CSL elements -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
536
lisp/citeproc/citeproc-cite.el
Normal file
536
lisp/citeproc/citeproc-cite.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
270
lisp/citeproc/citeproc-context.el
Normal file
270
lisp/citeproc/citeproc-context.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Provides the `citeproc-context' CL-structure type to represent rendering
|
||||
;; contexts for CSL elements, and functions for accessing context-dependent
|
||||
;; information (variable and term values etc.). Also contains some functions
|
||||
;; that perform context-dependent formatting (e.g., quoting).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'let-alist)
|
||||
(require 'subr-x)
|
||||
|
||||
(require 'citeproc-lib)
|
||||
(require 'citeproc-rt)
|
||||
(require 'citeproc-term)
|
||||
(require 'citeproc-prange)
|
||||
(require 'citeproc-style)
|
||||
|
||||
(cl-defstruct (citeproc-context (:constructor citeproc-context--create))
|
||||
"A struct representing the context for rendering CSL elements."
|
||||
vars macros terms date-text date-numeric opts locale-opts
|
||||
mode render-mode render-year-suffix no-external-links locale)
|
||||
|
||||
(defun citeproc-context-create (var-alist style mode render-mode
|
||||
&optional no-external-links)
|
||||
"Create a citeproc-context struct from var-values VAR-ALIST and csl style STYLE.
|
||||
MODE is either `bib' or `cite', RENDER-MODE is `display' or `sort'."
|
||||
(citeproc-context--create
|
||||
:vars var-alist
|
||||
:macros (citeproc-style-macros style)
|
||||
:terms (citeproc-style-terms style)
|
||||
:date-text (citeproc-style-date-text style)
|
||||
:date-numeric (citeproc-style-date-numeric style)
|
||||
:opts (citeproc-style-global-opts style mode)
|
||||
:locale (citeproc-style-locale style)
|
||||
:locale-opts (citeproc-style-locale-opts style)
|
||||
:mode mode
|
||||
:render-mode render-mode
|
||||
:render-year-suffix (not (citeproc-style-uses-ys-var style))
|
||||
:no-external-links no-external-links))
|
||||
|
||||
(defconst citeproc--short-long-var-alist
|
||||
'((title . title-short) (container-title . container-title-short))
|
||||
"Alist mapping the long form of variables names to their short form.")
|
||||
|
||||
(defun citeproc-var-value (var context &optional form)
|
||||
"Return the value of csl variable VAR in CONTEXT.
|
||||
VAR is a symbol, CONTEXT is a `citeproc-context' struct, and the
|
||||
optional FORM can be nil, 'short or 'long."
|
||||
(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
|
||||
280
lisp/citeproc/citeproc-date.el
Normal file
280
lisp/citeproc/citeproc-date.el
Normal file
@@ -0,0 +1,280 @@
|
||||
;;; citeproc-date.el --- CSL date rendering -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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 "<suppressed-date>" context)
|
||||
(let ((rendered-date (citeproc-date--render-parts d part-attrs context)))
|
||||
(citeproc-rt-join-formatted attrs rendered-date context))))
|
||||
|
||||
(defun citeproc-date--render-parts (d part-attrs context &optional no-last-suffix)
|
||||
"Render the parts of citeproc-date D according to PART-ATTRS.
|
||||
Return a list of rich-text contents. If optional NO-LAST-SUFFIX
|
||||
is non-nil then remove the suffix attribute of the last rendered
|
||||
element (used for date range rendering)."
|
||||
(let ((result (--map (pcase (car it)
|
||||
('year (citeproc-date--render-year d (cdr it) context))
|
||||
('month (citeproc-date--render-month d (cdr it) context))
|
||||
('day (citeproc-date--render-day d (cdr it) context)))
|
||||
part-attrs)))
|
||||
(-if-let* ((n-l-s no-last-suffix)
|
||||
(last (car (last result)))
|
||||
(wo-suffix (and (consp last)
|
||||
(cons (--remove (eq 'suffix (car it)) (car last))
|
||||
(cdr last)))))
|
||||
(-snoc (butlast result) wo-suffix)
|
||||
result)))
|
||||
|
||||
(defun citeproc-date--render-range-parts (d1 d2 part-attrs sep context)
|
||||
"Render the parts of citeproc-dates D1 and D2 according to PART-ATTRS.
|
||||
PART-ATTRS is a list containing either part-attrs or lists of part-attrs.
|
||||
The formers are only rendered for D1, while the latters are rendered for both
|
||||
D1 and D2. Return a list of rich-text contents."
|
||||
(--mapcat (pcase (car it)
|
||||
('year (list (citeproc-date--render-year d1 (cdr it) context)))
|
||||
('month (list (citeproc-date--render-month d1 (cdr it) context)))
|
||||
('day (list (citeproc-date--render-day d1 (cdr it) context)))
|
||||
(_ (-concat (citeproc-date--render-parts d1 it context t)
|
||||
(list sep)
|
||||
(citeproc-date--render-parts d2 it context))))
|
||||
part-attrs))
|
||||
|
||||
(defun citeproc-date--render-range (d1 d2 attrs part-attrs context)
|
||||
"Render the range given by dates D1 D2 according to attrs."
|
||||
(if (citeproc-var-value 'suppress-date context)
|
||||
(citeproc-rt-format-single attrs "" context)
|
||||
(let* ((gran (min (citeproc-date--gran d1)
|
||||
(citeproc-date--attrs-gran part-attrs)))
|
||||
(range-sep (or (alist-get 'range-delimiter
|
||||
(alist-get (elt '(year month day) gran)
|
||||
part-attrs))
|
||||
"–"))
|
||||
(range-p-attrs
|
||||
(cond ((/= (citeproc-date-year d1) (citeproc-date-year d2))
|
||||
(list part-attrs))
|
||||
((/= (citeproc-date-month d1) (citeproc-date-month d2))
|
||||
(let ((year-part (--find (eq 'year (car it))
|
||||
part-attrs))
|
||||
(attrs-wo-year
|
||||
(--remove (eq 'year (car it))
|
||||
part-attrs)))
|
||||
(cond ((eq (caar part-attrs) 'year)
|
||||
(list year-part attrs-wo-year))
|
||||
((eq (caar (last part-attrs)) 'year)
|
||||
(list attrs-wo-year year-part))
|
||||
(t (list attrs-wo-year)))))
|
||||
(t (--map (if (eq (car it) 'day) (list it) it)
|
||||
part-attrs))))
|
||||
(rendered-range (citeproc-date--render-range-parts d1 d2 range-p-attrs range-sep
|
||||
context)))
|
||||
(citeproc-rt-join-formatted attrs rendered-range context))))
|
||||
|
||||
(defun citeproc-date--attrs-gran (d-attrs)
|
||||
"Return the granularity (smallest unit) of date-attrs alist D-ATTRS.
|
||||
The returned value is 0, 1 or 2, corresponding to a year, month
|
||||
or day granularity."
|
||||
(cond ((assoc 'day d-attrs) 2)
|
||||
((assoc 'month d-attrs) 1)
|
||||
(t 0)))
|
||||
|
||||
(defun citeproc-date--gran (date)
|
||||
"Return the granularity (smallest unit) in citeproc-date struct DATE.
|
||||
The returned value is 0, 1 or 2, corresponding to a year, month
|
||||
or day granularity."
|
||||
(cond ((citeproc-date-day date) 2)
|
||||
((citeproc-date-month date) 1)
|
||||
(t 0)))
|
||||
|
||||
(defun citeproc-date--render-year (d attrs context)
|
||||
"Render the year in date D according to formatting in ATTRS.
|
||||
D is a citeproc-date structure. Return a rich-text content."
|
||||
(-let* ((form (alist-get 'form attrs))
|
||||
(year (citeproc-date-year d))
|
||||
(s (number-to-string (abs year)))
|
||||
(era
|
||||
(cond ((> year 999) "")
|
||||
((> year 0) (citeproc-term-get-text "ad" context))
|
||||
(t (citeproc-term-get-text "bc" context)))))
|
||||
|
||||
(citeproc-rt-format-single attrs (concat (if (string= form "short")
|
||||
(s-right 2 s)
|
||||
s)
|
||||
era)
|
||||
context)))
|
||||
|
||||
(defun citeproc-date--render-month (d attrs context)
|
||||
"Render the month in date D according to formatting in ATTRS.
|
||||
D is a citeproc-date structure. Return a rich-text content."
|
||||
(-if-let (month (citeproc-date-month d))
|
||||
(let ((form (alist-get 'form attrs))
|
||||
(term-pref (if (citeproc-date-season d)
|
||||
"season-" "month-")))
|
||||
(citeproc-rt-format-single
|
||||
attrs
|
||||
(pcase (citeproc-lib-intern form)
|
||||
('numeric (number-to-string month))
|
||||
('numeric-leading-zeros (format "%02d" month))
|
||||
('short (citeproc-term-inflected-text
|
||||
(concat term-pref (format "%02d" month))
|
||||
'short nil context))
|
||||
(_ (citeproc-term-inflected-text
|
||||
(concat term-pref (format "%02d" month))
|
||||
'long nil context)))
|
||||
context))
|
||||
nil))
|
||||
|
||||
(defun citeproc-date--render-day (d attrs context)
|
||||
"Render the day in date D according to formatting in ATTRS.
|
||||
D is a citeproc-date structure. Return a rich-text content."
|
||||
(-if-let (day (citeproc-date-day d))
|
||||
(let ((form (alist-get 'form attrs))
|
||||
(month (citeproc-date-month d)))
|
||||
(citeproc-rt-format-single
|
||||
attrs
|
||||
(cond
|
||||
((string= form "numeric-leading-zeros")
|
||||
(format "%02d" day))
|
||||
((and (string= form "ordinal")
|
||||
(or (= day 1)
|
||||
(not (string= "true"
|
||||
(alist-get 'limit-day-ordinals-to-day-1
|
||||
(citeproc-context-locale-opts context))))))
|
||||
(citeproc-number--format-as-ordinal (number-to-string day)
|
||||
(concat "month-" (format "%02d" month))
|
||||
context))
|
||||
(t (number-to-string day)))
|
||||
context))
|
||||
nil))
|
||||
|
||||
(provide 'citeproc-date)
|
||||
|
||||
;;; citeproc-date.el ends here
|
||||
247
lisp/citeproc/citeproc-disamb.el
Normal file
247
lisp/citeproc/citeproc-disamb.el
Normal file
@@ -0,0 +1,247 @@
|
||||
;;; citeproc-disamb.el --- disambiguate ambiguous cites -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
331
lisp/citeproc/citeproc-formatters.el
Normal file
331
lisp/citeproc/citeproc-formatters.el
Normal file
@@ -0,0 +1,331 @@
|
||||
;; citeproc-formatters.el --- output formatters -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017-2021 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Provides 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 "<<citeproc_bib_item_" y ">>" 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 "<a href=\"" y "\">" x "</a>")))
|
||||
(cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
|
||||
x "</a>")))
|
||||
(bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
|
||||
x)))
|
||||
(font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
|
||||
(font-style-oblique . ,(lambda (x)
|
||||
(concat "<span style=\"font-style:oblique;\"" x "</span>")))
|
||||
(font-variant-small-caps . ,(lambda (x)
|
||||
(concat
|
||||
"<span style=\"font-variant:small-caps;\">" x "</span>")))
|
||||
(font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
|
||||
(text-decoration-underline .
|
||||
,(lambda (x)
|
||||
(concat
|
||||
"<span style=\"text-decoration:underline;\">" x "</span>")))
|
||||
(vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
|
||||
(vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
|
||||
(vertical-align-baseline . ,(lambda (x) (concat "<span style=\"baseline\">" x "</span>")))
|
||||
(display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
|
||||
x "</div>")))
|
||||
(display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
|
||||
x "</div>\n ")))
|
||||
(display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
|
||||
x "</div>\n")))
|
||||
(display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
|
||||
|
||||
(defconst citeproc-fmt--csl-test-alist
|
||||
`((unformatted . citeproc-fmt--xml-escape)
|
||||
(cited-item-no . ,(lambda (x y) (concat "<a href=\"#citeproc_bib_item_" y "\">"
|
||||
x "</a>")))
|
||||
(bib-item-no . ,(lambda (x y) (concat "<a id=\"citeproc_bib_item_" y "\"></a>"
|
||||
x)))
|
||||
(font-style-italic . ,(lambda (x) (concat "<i>" x "</i>")))
|
||||
(font-style-oblique . ,(lambda (x)
|
||||
(concat "<span style=\"font-style:oblique;\"" x "</span>")))
|
||||
(font-variant-small-caps . ,(lambda (x)
|
||||
(concat
|
||||
"<span style=\"font-variant:small-caps;\">" x "</span>")))
|
||||
(font-weight-bold . ,(lambda (x) (concat "<b>" x "</b>")))
|
||||
(text-decoration-underline .
|
||||
,(lambda (x)
|
||||
(concat
|
||||
"<span style=\"text-decoration:underline;\">" x "</span>")))
|
||||
(vertical-align-sub . ,(lambda (x) (concat "<sub>" x "</sub>")))
|
||||
(vertical-align-sup . ,(lambda (x) (concat "<sup>" x "</sup>")))
|
||||
(vertical-align-baseline . ,(lambda (x) (concat "<span style=\"baseline\">" x "</span>")))
|
||||
(display-left-margin . ,(lambda (x) (concat "\n <div class=\"csl-left-margin\">"
|
||||
x "</div>")))
|
||||
(display-right-inline . ,(lambda (x) (concat "<div class=\"csl-right-inline\">"
|
||||
x "</div>\n ")))
|
||||
(display-block . ,(lambda (x) (concat "\n\n <div class=\"csl-block\">"
|
||||
x "</div>\n")))
|
||||
(display-indent . ,(lambda (x) (concat "<div class=\"csl-indent\">" x "</div>\n ")))))
|
||||
|
||||
(defun citeproc-fmt--html-bib-formatter (items _bib-format)
|
||||
"Return a html bibliography from already formatted ITEMS."
|
||||
(concat "<div class=\"csl-bib-body\">\n"
|
||||
(mapconcat (lambda (i)
|
||||
(concat " <div class=\"csl-entry\">" i "</div>\n"))
|
||||
items
|
||||
"")
|
||||
"</div>"))
|
||||
|
||||
;; LaTeX
|
||||
|
||||
(defconst citeproc-fmt--latex-esc-regex
|
||||
(regexp-opt '("_" "&" "#" "%" "$"))
|
||||
"Regular expression matching characters to be escaped in LaTeX output.")
|
||||
|
||||
(defun citeproc-fmt--latex-escape (s)
|
||||
"Return the LaTeX-escaped version of string S."
|
||||
(replace-regexp-in-string citeproc-fmt--latex-esc-regex "\\\\\\&" s))
|
||||
|
||||
(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 "<text:a xlink:type=\"simple\" xlink:href=\""
|
||||
y "\">" x "</text:a>")))
|
||||
(cited-item-no
|
||||
. ,(lambda (x y) (concat "<text:a xlink:type=\"simple\" xlink:href=\"#citeproc_bib_item_"
|
||||
y "\">" x "</text:a>")))
|
||||
(bib-item-no
|
||||
. ,(lambda (x y)
|
||||
(concat "<text:bookmark-start text:name=\"OrgXref.citeproc_bib_item_" y "\"/>"
|
||||
"<text:bookmark text:name=\"citeproc_bib_item_" y "\"/>"
|
||||
"<text:bookmark-end text:name=\"OrgXref.citeproc_bib_item_" y "\"/>" x)))
|
||||
(font-style-italic
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
|
||||
(font-style-oblique
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"Emphasis\">" x "</text:span>")))
|
||||
;; NOTE: small caps support requires the availability of the OrgSmallcaps ODT style
|
||||
;; this requires an addition to or replacement of the default OrgOdtStyles.xml
|
||||
(font-variant-small-caps
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"OrgSmallCaps\">" x "</text:span>")))
|
||||
(font-weight-bold
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"Bold\">" x "</text:span>")))
|
||||
(text-decoration-underline
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"Underline\">" x "</text:span>")))
|
||||
(vertical-align-sub
|
||||
. ,(lambda (x) (concat "<text:span text:style-name=\"OrgSubscript\">" x "</text:span>")))
|
||||
(vertical-align-sup
|
||||
. ,(lambda (x)
|
||||
(concat "<text:span text:style-name=\"OrgSuperscript\">" x "</text:span>")))
|
||||
;; TODO:
|
||||
;; - display-left-margin
|
||||
;; - display-right-inline
|
||||
;; - display-block
|
||||
;; - display-indent
|
||||
))
|
||||
|
||||
(defun citeproc-fmt--org-odt-bib-formatter (items _bib-format)
|
||||
"Return a html bibliography from already formatted ITEMS."
|
||||
(mapconcat (lambda (i)
|
||||
(concat "<text:p text:style-name=\"Text_20_body\">" i "</text:p>"))
|
||||
items
|
||||
"\n"))
|
||||
|
||||
;; Define the formatters alist
|
||||
|
||||
(defvar citeproc-fmt--formatters-alist
|
||||
`((org-odt . ,(citeproc-formatter-create
|
||||
:rt (citeproc-formatter-fun-create citeproc-fmt--org-odt-alist)
|
||||
:bib #'citeproc-fmt--org-odt-bib-formatter
|
||||
))
|
||||
(html . ,(citeproc-formatter-create
|
||||
:rt (citeproc-formatter-fun-create citeproc-fmt--html-alist)
|
||||
:bib #'citeproc-fmt--html-bib-formatter))
|
||||
(csl-test . ,(citeproc-formatter-create
|
||||
:rt (citeproc-formatter-fun-create citeproc-fmt--csl-test-alist)
|
||||
:bib #'citeproc-fmt--html-bib-formatter
|
||||
:no-external-links t))
|
||||
(raw . ,(citeproc-formatter-create :rt #'identity :bib (lambda (x _) x)))
|
||||
(org . ,(citeproc-formatter-create
|
||||
:rt (citeproc-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
|
||||
148
lisp/citeproc/citeproc-generic-elements.el
Normal file
148
lisp/citeproc/citeproc-generic-elements.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
101
lisp/citeproc/citeproc-itemdata.el
Normal file
101
lisp/citeproc/citeproc-itemdata.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
178
lisp/citeproc/citeproc-itemgetters.el
Normal file
178
lisp/citeproc/citeproc-itemgetters.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
164
lisp/citeproc/citeproc-lib.el
Normal file
164
lisp/citeproc/citeproc-lib.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
93
lisp/citeproc/citeproc-locale.el
Normal file
93
lisp/citeproc/citeproc-locale.el
Normal file
@@ -0,0 +1,93 @@
|
||||
;; citeproc-locale.el --- CSL locale related functions -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
58
lisp/citeproc/citeproc-macro.el
Normal file
58
lisp/citeproc/citeproc-macro.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
438
lisp/citeproc/citeproc-name.el
Normal file
438
lisp/citeproc/citeproc-name.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
160
lisp/citeproc/citeproc-number.el
Normal file
160
lisp/citeproc/citeproc-number.el
Normal file
@@ -0,0 +1,160 @@
|
||||
;;; citeproc-number.el --- render CSL number elements -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright "(C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
19
lisp/citeproc/citeproc-pkg.el
Normal file
19
lisp/citeproc/citeproc-pkg.el
Normal file
@@ -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:
|
||||
128
lisp/citeproc/citeproc-prange.el
Normal file
128
lisp/citeproc/citeproc-prange.el
Normal file
@@ -0,0 +1,128 @@
|
||||
;;; citeproc-prange.el --- page-range rendering -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
224
lisp/citeproc/citeproc-proc.el
Normal file
224
lisp/citeproc/citeproc-proc.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
569
lisp/citeproc/citeproc-rt.el
Normal file
569
lisp/citeproc/citeproc-rt.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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 "</[[:alnum:]]+>" 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 "<suppressed-date>")
|
||||
(list (car node) ys)
|
||||
(let ((full-ys (if (or (not (stringp content))
|
||||
(s-matches-p "[[:digit:]]$" content))
|
||||
ys
|
||||
(concat "-" ys))))
|
||||
(-snoc node `(((rendered-var . year-suffix)) ,full-ys)))))))
|
||||
(citeproc-rt-transform-first rt #'rendered-date-var-p #'add-suffix)))
|
||||
|
||||
(defun citeproc-rt-replace-first-names (rt replacement)
|
||||
"Replace RT's first name-var content with REPLACEMENT.
|
||||
Return an (RT . SUCCESS) pair, where RT is the resulting
|
||||
rich-text, and SUCCESS is non-nil iff the replacement has been
|
||||
successful."
|
||||
(cl-flet ((rendered-name-var-p
|
||||
(node)
|
||||
(and (consp node)
|
||||
(assoc 'rendered-names (car node))))
|
||||
(replace (_node) replacement))
|
||||
(citeproc-rt-transform-first rt #'rendered-name-var-p #'replace)))
|
||||
|
||||
(defun citeproc-rt-count-names (rt)
|
||||
"Return a count of the rendered names in RT."
|
||||
(if (consp rt)
|
||||
(if (alist-get 'name-id (car rt)) 1
|
||||
(apply #'+ (mapcar #'citeproc-rt-count-names (cdr rt))))
|
||||
0))
|
||||
|
||||
(defun citeproc-rt-cull-spaces-puncts (rt)
|
||||
"Remove unnecessary characters from rich-text RT."
|
||||
(let* ((plain (citeproc-rt-to-plain rt))
|
||||
(updated (citeproc-rt-update-from-plain
|
||||
rt (citeproc-s-cull-spaces-puncts plain))))
|
||||
(citeproc-rt-format updated
|
||||
(lambda (x) (replace-regexp-in-string "+" "" x)))))
|
||||
|
||||
(defun citeproc-rt-render-affixes (rt &optional shallow)
|
||||
"Render the affixes in rich-text RT.
|
||||
If SHALLOW is non-nil then render only the affixes for the first
|
||||
level."
|
||||
(if (not (consp rt))
|
||||
rt
|
||||
(-let* (((attrs . contents) rt)
|
||||
(rendered
|
||||
(if shallow ; We do the recursive call depending on SHALLOW
|
||||
contents
|
||||
(-non-nil (--map (citeproc-rt-render-affixes it) contents)))))
|
||||
(if rendered
|
||||
(let-alist attrs
|
||||
(let ((delimited (if .delimiter
|
||||
(cdr (--mapcat (list .delimiter it) rendered))
|
||||
rendered)))
|
||||
(if (or .suffix .prefix)
|
||||
(let (result
|
||||
outer-attrs
|
||||
(inner-attrs
|
||||
(citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)))
|
||||
(when .display ; The display attribute should encompass affixes
|
||||
(setq outer-attrs (list (cons 'display .display))
|
||||
inner-attrs (--remove (eq (car it) 'display) inner-attrs)))
|
||||
(when .suffix (push .suffix result))
|
||||
(push (cons inner-attrs
|
||||
delimited)
|
||||
result)
|
||||
(when .prefix (push .prefix result))
|
||||
(cons outer-attrs result))
|
||||
(cons (citeproc-rt-select-attrs attrs citeproc-rt-format-attrs)
|
||||
delimited))))
|
||||
nil))))
|
||||
|
||||
(defun citeproc-rt-dedup (rt)
|
||||
"Remove duplicate substituted renderings from content RT."
|
||||
(car (citeproc-rt--dedup-single rt nil)))
|
||||
|
||||
(defun citeproc-rt--dedup-single (rt substs)
|
||||
"Remove duplicate subst. var renderings from RT.
|
||||
SUBSTS contains an initial list of vars to be removed. Return
|
||||
a (<deduplicated content of RT> <substitued vars in RT> <vars in RT>) list."
|
||||
(if (not (consp rt))
|
||||
(list rt nil nil)
|
||||
(-let* (((attrs . cs) rt)
|
||||
((&alist 'subst subst
|
||||
'rendered-var var)
|
||||
attrs))
|
||||
(if (and var (memq var substs))
|
||||
(list nil nil nil)
|
||||
(-let (((new-c s v) (citeproc-rt--dedup-multi cs substs)))
|
||||
(list (cons (--reject (memq (car it) '(subst rendered-vars)) attrs)
|
||||
new-c)
|
||||
(if subst
|
||||
(-concat v (when var (list var)))
|
||||
s)
|
||||
(-concat v (if var
|
||||
(list var)
|
||||
nil))))))))
|
||||
|
||||
(defun citeproc-rt--dedup-multi (cs substs)
|
||||
(if cs
|
||||
(-let* (((c s1 v1) (citeproc-rt--dedup-single (car cs) substs))
|
||||
((cs s2 v2) (citeproc-rt--dedup-multi (cdr cs) (-concat substs s1))))
|
||||
(list (cons c cs)
|
||||
(-concat s1 s2)
|
||||
(-concat v1 v2)))
|
||||
(list nil nil nil)))
|
||||
|
||||
(defun citeproc-rt-finalize (rt &optional punct-in-quote)
|
||||
"Finalize rich text RT.
|
||||
If the optional PUNCT-IN-QUOTE is non-nil then put punctuation
|
||||
inside quotes.
|
||||
|
||||
Note: Finalization doesn't include culling, because some
|
||||
rich-text transformations require the state before culling (e.g.
|
||||
the replacement of subsequent authors)."
|
||||
;; The first step is to replace the internally used `modifier letter
|
||||
;; apostrophe' characters with the normal `right single quotation marks'
|
||||
(citeproc-rt-format (citeproc-rt-simplify-deep
|
||||
(citeproc-rt-italics-flipflop
|
||||
(if punct-in-quote (citeproc-rt-punct-in-quote rt) rt)))
|
||||
(lambda (x) (s-replace "ʼ" "’" x))))
|
||||
|
||||
(defun citeproc-rt--attr-values (r attr)
|
||||
"Return the list of ATTR values in raw rich-text content R.
|
||||
The values are ordered depth-first."
|
||||
(if (listp r)
|
||||
(let ((val (alist-get attr (car r)))
|
||||
(body-vals (--mapcat (citeproc-rt--attr-values it attr) (cdr r))))
|
||||
(if val (cons val body-vals)
|
||||
body-vals))
|
||||
nil))
|
||||
|
||||
(defun citeproc-rt-rendered-name-ids (r)
|
||||
"Return the list of name ids in raw content R."
|
||||
(citeproc-rt--attr-values r 'name-id))
|
||||
|
||||
(defun citeproc-rt-rendered-vars (r)
|
||||
"Return the list of rendered vars in raw content R."
|
||||
(citeproc-rt--attr-values r 'rendered-var))
|
||||
|
||||
(defun citeproc-rt-rendered-date-vars (r)
|
||||
"Return the list of date vars in raw content R."
|
||||
(--select (memq it citeproc--date-vars) (citeproc-rt-rendered-vars r)))
|
||||
|
||||
(defun citeproc-rt-rendered-name-vars (r)
|
||||
"Return the list of name vars in raw content R."
|
||||
(--select (memq it citeproc--name-vars) (citeproc-rt-rendered-vars r)))
|
||||
|
||||
;;; Helpers for bibliography rendering
|
||||
|
||||
(defun citeproc-rt-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
|
||||
274
lisp/citeproc/citeproc-s.el
Normal file
274
lisp/citeproc/citeproc-s.el
Normal file
@@ -0,0 +1,274 @@
|
||||
;;; citeproc-s.el --- citeproc-el string functions -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; String utility functions for citeproc-el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'thingatpt)
|
||||
(require 's)
|
||||
|
||||
;; 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 "\\(<span class=\"nocase\">\\|</span>\\|: +\\w\\)"))
|
||||
(protect-level 0)
|
||||
(first t)
|
||||
result)
|
||||
(dolist (slice sliced)
|
||||
(push
|
||||
(pcase slice
|
||||
("<span class=\"nocase\">" (cl-incf protect-level) (if omit-nocase nil slice))
|
||||
("</span>" (cl-decf protect-level) (if omit-nocase nil slice))
|
||||
;; Don't touch the first letter after a colon since it 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
|
||||
191
lisp/citeproc/citeproc-sort.el
Normal file
191
lisp/citeproc/citeproc-sort.el
Normal file
@@ -0,0 +1,191 @@
|
||||
;;; citeproc-sort.el --- cite and bibliography sorting -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
344
lisp/citeproc/citeproc-style.el
Normal file
344
lisp/citeproc/citeproc-style.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
65
lisp/citeproc/citeproc-subbibs.el
Normal file
65
lisp/citeproc/citeproc-subbibs.el
Normal file
@@ -0,0 +1,65 @@
|
||||
;;; citeproc-subbibs.el --- support for subbibliographies -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2021 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
113
lisp/citeproc/citeproc-term.el
Normal file
113
lisp/citeproc/citeproc-term.el
Normal file
@@ -0,0 +1,113 @@
|
||||
;;; citeproc-term.el --- functions for term localization -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 András Simonyi
|
||||
|
||||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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
|
||||
207
lisp/citeproc/citeproc-test-human.el
Normal file
207
lisp/citeproc/citeproc-test-human.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Functions to create ERT tests from tests in CSL test suite format. The
|
||||
;; official tests can be found at
|
||||
;; <https://github.com/citation-style-language/test-suite>.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'f)
|
||||
(require 's)
|
||||
(require 'json)
|
||||
(require 'ert)
|
||||
(require 'string-inflection)
|
||||
|
||||
(require 'citeproc)
|
||||
|
||||
(defvar citeproc-test-human--locale-dir "./test/locales")
|
||||
|
||||
(defun citeproc-test-human--parse-testfile (file)
|
||||
"Return a parsed form of CSL test FILE."
|
||||
(let (result
|
||||
(json-array-type 'list)
|
||||
(json-key-type 'symbol))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char 1)
|
||||
(setq result (list (cons 'YEAR-SUFF
|
||||
(re-search-forward "variable=\"year-suffix\"" nil t))))
|
||||
(goto-char 1)
|
||||
(while (re-search-forward ">>=+ \\{1,2\\}\\([[:graph:]]+\\) =+>>" nil t)
|
||||
(let ((section (intern (buffer-substring (nth 2 (match-data))
|
||||
(nth 3 (match-data)))))
|
||||
(start (1+ (point)))
|
||||
end)
|
||||
(re-search-forward "<<=" nil t)
|
||||
(setq end (- (car (match-data)) 1))
|
||||
(push (cons section (pcase section
|
||||
('OUTPUT-FORMAT
|
||||
(intern (buffer-substring-no-properties start end)))
|
||||
('CSL (buffer-substring-no-properties start end))
|
||||
((or 'INPUT 'CITATIONS 'CITATION-ITEMS)
|
||||
(goto-char (- start 1)) (json-read))
|
||||
(_ (buffer-substring start end))))
|
||||
result))))
|
||||
result))
|
||||
|
||||
(defun citeproc-test-human--create-getter (items)
|
||||
"Return a getter function for ITEMS.
|
||||
ITEMS is the parsed representation of the `INPUT' section of a
|
||||
CSL test."
|
||||
(lambda (itemids)
|
||||
(let (result)
|
||||
(dolist (item items result)
|
||||
(let ((id (citeproc-s-from-num-or-s (alist-get 'id item))))
|
||||
(when (member id itemids)
|
||||
(push (cons id item) result)))))))
|
||||
|
||||
(defun citeproc-test-human--proc-from-style (style parsed-input)
|
||||
"Create a processor from STYLE and PARSED-INPUT."
|
||||
(citeproc-create style
|
||||
(citeproc-test-human--create-getter parsed-input)
|
||||
(citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
|
||||
|
||||
(defun citeproc-test-human--proc-from-testfile (file)
|
||||
"Create an (itemless) processor from a test FILE."
|
||||
(let ((style-string (alist-get 'CSL (citeproc-test-human--parse-testfile file)))
|
||||
(locale-getter (citeproc-locale-getter-from-dir citeproc-test-human--locale-dir)))
|
||||
(citeproc-create style-string nil locale-getter)))
|
||||
|
||||
(defun citeproc-test-human--parse-citation (ct-desc &optional cites-only)
|
||||
"Parse test citations description CT-DESC.
|
||||
Return a list of citation structures. If CITES-ONLY is non-nil
|
||||
then the input is list of cites."
|
||||
(if cites-only
|
||||
(citeproc-citation-create
|
||||
:cites (-map #'citeproc-test-human--normalize-cite ct-desc))
|
||||
(let ((citation-info (car ct-desc)))
|
||||
(let-alist (alist-get 'properties citation-info)
|
||||
(citeproc-citation-create
|
||||
:cites (-map #'citeproc-test-human--normalize-cite
|
||||
(alist-get 'citationItems citation-info))
|
||||
:note-index .noteIndex
|
||||
:mode (citeproc-lib-intern .mode)
|
||||
:capitalize-first .capitalize-first
|
||||
:suppress-affixes .suppress-affixes
|
||||
:ignore-et-al .ignore-et-al)))))
|
||||
|
||||
(defun citeproc-test-human--normalize-cite (cite)
|
||||
"Normalize a test CITE."
|
||||
(--map (let ((val (cdr it)))
|
||||
(if (numberp val) (cons (car it) (number-to-string val)) it))
|
||||
cite))
|
||||
|
||||
(defun citeproc-test-human--run-parsed (parsed)
|
||||
"Run the parsed CSL test PARSED.
|
||||
Return the resulting output."
|
||||
(-let* (((&alist 'CSL style
|
||||
'INPUT input
|
||||
'MODE mode
|
||||
'CITATION-ITEMS citation-items
|
||||
'CITATIONS citations
|
||||
'OUTPUT-FORMAT output-format)
|
||||
parsed)
|
||||
(output-format (or output-format 'csl-test))
|
||||
(proc (citeproc-test-human--proc-from-style style input)))
|
||||
(--each input
|
||||
(citeproc-proc-put-item-by-id proc
|
||||
(citeproc-s-from-num-or-s (alist-get 'id it))))
|
||||
(when (string= mode "citation")
|
||||
(cond
|
||||
(citation-items
|
||||
(citeproc-append-citations (--map (citeproc-test-human--parse-citation it t)
|
||||
citation-items)
|
||||
proc))
|
||||
(citations
|
||||
(citeproc-append-citations (mapcar #'citeproc-test-human--parse-citation citations)
|
||||
proc))
|
||||
(t (citeproc-append-citations (list (citeproc-test-human--parse-citation input t))
|
||||
proc))))
|
||||
(let ((output (if (string= mode "citation")
|
||||
(citeproc-render-citations proc output-format
|
||||
(when (eq 'csl-test output-format)
|
||||
'no-links))
|
||||
(car (citeproc-render-bib proc output-format 'no-links)))))
|
||||
(if (string= mode "citation") (s-join "\n" output) output))))
|
||||
|
||||
(defun citeproc-test-human--expected-from-parsed (parsed)
|
||||
"Return the expected output of parsed CSL test PARSED."
|
||||
(let ((expected (alist-get 'RESULT parsed)))
|
||||
(if (or (string= (s-left 5 expected) "..[0]")
|
||||
(string= (s-left 5 expected) ">>[0]"))
|
||||
(s-join "\n" (--map (substring it 6)
|
||||
(split-string expected "\n")))
|
||||
expected)))
|
||||
|
||||
(defun citeproc-test-human-create-from-file (file expected-fails &optional name-prefix)
|
||||
"Create an ERT test from a CSL test FILE.
|
||||
If optional NAME-PREFIX is non-nil then it is added the name of
|
||||
the created test after the obligatory `citeproc'."
|
||||
(let* ((parsed (citeproc-test-human--parse-testfile file))
|
||||
(expected (citeproc-test-human--expected-from-parsed parsed))
|
||||
(file-name (f-filename file))
|
||||
(test-name (intern
|
||||
(concat "citeproc-"
|
||||
(if name-prefix (concat name-prefix "-") "")
|
||||
(string-inflection-kebab-case-function
|
||||
(substring file-name 0 -4)))))
|
||||
(expected-fail (memq test-name expected-fails)))
|
||||
(eval `(ert-deftest ,test-name ()
|
||||
:expected-result ,(if expected-fail :failed :passed)
|
||||
(let ((citeproc-disambiguation-cite-pos 'subsequent))
|
||||
(should (string=
|
||||
,expected
|
||||
(citeproc-test-human--run-parsed ',parsed))))))))
|
||||
|
||||
(defun citeproc-test-human---read-expected-fails (expected-fails-file)
|
||||
"Read the list of tests expected to fail from EXPECTED-FAILS-FILE."
|
||||
(let* ((list-as-str (with-temp-buffer
|
||||
(insert-file-contents expected-fails-file)
|
||||
(buffer-string)))
|
||||
(split (split-string list-as-str "\n")))
|
||||
(--map (intern it) (butlast split))))
|
||||
|
||||
(defun citeproc-test-human-create-from-dir (dir &optional
|
||||
expected-fails-file name-prefix)
|
||||
"Create all CSL tests from DIR.
|
||||
Each file in DIR having the `txt' extension is read as a
|
||||
human-readable CSL test, and a corresponding ERT test is created.
|
||||
The created test's name will be constructed by prefixing the
|
||||
test's filename (without the extension) with `citeproc-'. If the
|
||||
optional EXPECTED-FAILS-FILE is non-nil then read that file as a
|
||||
list of tests whose failure is expected. If optional NAME-PREFIX
|
||||
is non-nil then it is added the names of the created tests after
|
||||
the obligatory `citeproc'. The file should contain one test-name
|
||||
per line (together with the `citeproc-' prefix)."
|
||||
(let ((expected-fails
|
||||
(if expected-fails-file
|
||||
(citeproc-test-human---read-expected-fails expected-fails-file)
|
||||
nil)))
|
||||
(dolist (test-file (f-glob (concat dir "/*.txt")))
|
||||
(citeproc-test-human-create-from-file test-file expected-fails
|
||||
name-prefix))))
|
||||
|
||||
(provide 'citeproc-test-human)
|
||||
|
||||
;;; citeproc-test-human.el ends here
|
||||
290
lisp/citeproc/citeproc.el
Normal file
290
lisp/citeproc/citeproc.el
Normal file
@@ -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 <andras.simonyi@gmail.com>
|
||||
;; Maintainer: András Simonyi <andras.simonyi@gmail.com>
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; citeproc-el is a library for rendering citations and bibliographies in styles
|
||||
;; described in the Citation Style Language (CSL).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'dash)
|
||||
(require 'queue)
|
||||
|
||||
(require 'citeproc-rt)
|
||||
(require 'citeproc-locale)
|
||||
(require 'citeproc-style)
|
||||
(require 'citeproc-choose)
|
||||
(require 'citeproc-generic-elements)
|
||||
(require 'citeproc-context)
|
||||
(require 'citeproc-itemdata)
|
||||
(require 'citeproc-proc)
|
||||
(require 'citeproc-cite)
|
||||
(require 'citeproc-sort)
|
||||
(require 'citeproc-formatters)
|
||||
(require 'citeproc-itemgetters)
|
||||
(require 'citeproc-subbibs)
|
||||
|
||||
;;; Public API
|
||||
|
||||
(defun citeproc-create (style it-getter loc-getter &optional loc force-loc)
|
||||
"Return a CSL processor for a given STYLE, IT-GETTER and LOC-GETTER.
|
||||
STYLE is either a path to a CSL style file or a CSL style as a
|
||||
string.
|
||||
IT-GETTER is an item-getter function that takes a list of itemid
|
||||
strings as its sole argument and returns an alist in which the
|
||||
given itemids are the keys and the values are the parsed csl
|
||||
json descriptions of the corresponding bibliography items (keys
|
||||
are symbols, arrays and hashes should be represented as lists
|
||||
and alists, respecively).
|
||||
LOC-GETTER is a function that takes a locale string (e.g.
|
||||
\"en-GB\") as an argument and returns a corresponding parsed
|
||||
CSL locale (as parsed by Emacs's `libxml-parse-xml-region').
|
||||
Optional LOC is the locale to use if the style doesn't specify a
|
||||
default one. Defaults to \"en-US\".
|
||||
If optional FORCE-LOC is non-nil then use locale LOC even if
|
||||
STYLE specifies a different one as default. Defaults to nil."
|
||||
(let ((style (citeproc-create-style style loc-getter loc force-loc))
|
||||
(names (make-hash-table :test 'equal))
|
||||
(itemdata (make-hash-table :test 'equal))
|
||||
(citations (make-queue)))
|
||||
(citeproc-proc--create :style style :getter it-getter :names names
|
||||
:itemdata itemdata :citations citations :finalized t)))
|
||||
|
||||
(defun citeproc-append-citations (citations proc)
|
||||
"Append CITATIONS to the list of citations in PROC.
|
||||
CITATIONS is a list of `citeproc-citation' structures."
|
||||
(let ((itemdata (citeproc-proc-itemdata proc))
|
||||
ids)
|
||||
;; Collect new itemids
|
||||
(dolist (citation citations)
|
||||
(dolist (cite (citeproc-citation-cites citation))
|
||||
(push (alist-get 'id cite) ids)))
|
||||
(let* ((uniq-ids (delete-dups (nreverse ids))) ; reverse pushed ids
|
||||
(new-ids (--remove (gethash it itemdata) uniq-ids)))
|
||||
;; Add all new items in one pass
|
||||
(citeproc-proc-put-items-by-id proc new-ids)
|
||||
;; 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
|
||||
@@ -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
|
||||
|
||||
192
lisp/queue.el
Normal file
192
lisp/queue.el
Normal file
@@ -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 <inge@lysator.liu.se>
|
||||
;; Toby Cubitt <toby-predictive@dr-qubit.org>
|
||||
;; Maintainer: Toby Cubitt <toby-predictive@dr-qubit.org>
|
||||
;; 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 <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
;;; 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 <tsc25@cantab.net>
|
||||
;;
|
||||
;; Upgrade data structure packages to latest versions.
|
||||
;;
|
||||
;; 2014-05-15 Toby S. Cubitt <tsc25@cantab.net>
|
||||
;;
|
||||
;; queue.el: fix buggy queue-first and queue-empty definitions.
|
||||
;;
|
||||
;; 2012-04-30 Toby S. Cubitt <tsc25@cantab.net>
|
||||
;;
|
||||
;; 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 <tsc25@cantab.net>
|
||||
;;
|
||||
;; Add queue.el
|
||||
;;
|
||||
|
||||
|
||||
|
||||
(provide 'queue)
|
||||
|
||||
|
||||
;;; queue.el ends here
|
||||
396
lisp/string-inflection.el
Normal file
396
lisp/string-inflection.el
Normal file
@@ -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 <akicho8@gmail.com>
|
||||
;; 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
|
||||
@@ -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 | |
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user