123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701 |
- ;;; oc.el --- Org Cite library -*- lexical-binding: t; -*-
- ;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
- ;; Author: Nicolas Goaziou <mail@nicolasgoaziou.fr>
- ;; This file is part of GNU 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 <https://www.gnu.org/licenses/>.
- ;;; Commentary:
- ;; This library provides tooling to handle citations in Org, e.g,
- ;; activate, follow, insert, and export them, respectively called
- ;; "activate", "follow", "insert" and "export" capabilities.
- ;; Libraries responsible for providing some, or all, of these
- ;; capabilities are called "citation processors".
- ;; Such processors are defined using `org-cite-register-processor'.
- ;; Using this function, it is possible, in addition to giving it a
- ;; name, to attach functions associated to capabilities. As such, a
- ;; processor handling citation export must set the `:export-citation'
- ;; property to an appropriate function. Likewise, "activate"
- ;; capability requires an appropriate `:activate' property, "insert"
- ;; requires `:insert' property and, unsurprisingly, "follow"
- ;; capability implies `:follow' property.
- ;; As a user, the first thing to do is setting a bibliography, either
- ;; globally with `org-cite-global-bibliography', or locally using one
- ;; or more "bibliography" keywords. Then one can select any
- ;; registered processor for each capability by providing a processor
- ;; name to the variables `org-cite-activate-processor' and
- ;; `org-cite-follow-processor'.
- ;; The "export" capability is slightly more involved as one need to
- ;; select the processor providing it, but may also provide a default
- ;; style for citations and bibliography. Also, the choice of an
- ;; export processor may depend of the current export back-end. The
- ;; association between export back-ends and triplets of parameters can
- ;; be set in `org-cite-export-processors' variable, or in a document,
- ;; through the "cite_export" keyword.
- ;; Eventually, this library provides some tools, mainly targeted at
- ;; processor implementors. Most are export-specific and are located
- ;; in the "Tools only available during export" and "Tools generating
- ;; or operating on parsed data" sections.
- ;; The few others can be used directly from an Org buffer, or operate
- ;; on processors. See "Generic tools" section.
- ;;; Code:
- (require 'org-macs)
- (org-assert-version)
- (require 'org-compat)
- (require 'org-macs)
- (require 'seq)
- (declare-function org-at-heading-p "org" (&optional _))
- (declare-function org-collect-keywords "org" (keywords &optional unique directory))
- (declare-function org-element-adopt-elements "org-element" (parent &rest children))
- (declare-function org-element-citation-parser "org-element" ())
- (declare-function org-element-citation-reference-parser "org-element" ())
- (declare-function org-element-class "org-element" (datum &optional parent))
- (declare-function org-element-contents "org-element" (element))
- (declare-function org-element-create "org-element" (type &optional props &rest children))
- (declare-function org-element-extract-element "org-element" (element))
- (declare-function org-element-insert-before "org-element" (element location))
- (declare-function org-element-lineage "org-element" (datum &optional types with-self))
- (declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
- (declare-function org-element-normalize-string "org-element" (s))
- (declare-function org-element-parse-buffer "org-element" (&optional granularity visible-only))
- (declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
- (declare-function org-element-context "org-element" (&optional element))
- (declare-function org-element-property "org-element" (property element))
- (declare-function org-element-put-property "org-element" (element property value))
- (declare-function org-element-restriction "org-element" (element))
- (declare-function org-element-set-element "org-element" (old new))
- (declare-function org-element-type "org-element" (element))
- (declare-function org-export-derived-backend-p "org-export" (backend &rest backends))
- (declare-function org-export-get-next-element "org-export" (blob info &optional n))
- (declare-function org-export-get-previous-element "org-export" (blob info &optional n))
- (declare-function org-export-raw-string "org-export" (s))
- (defvar org-complex-heading-regexp)
- (defvar org-element-all-objects)
- (defvar org-element-citation-key-re)
- (defvar org-element-citation-prefix-re)
- (defvar org-element-parsed-keywords)
- ;;; Constants
- ;; Borrowed from "citeproc.el" library.
- (defconst org-cite--default-region-alist
- '(("af" . "za") ("ca" . "ad") ("cs" . "cz") ("cy" . "gb")
- ("da" . "dk") ("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 languages to their default region.
- Only those languages are given for which the default region is not simply the
- result of duplicating the language part.")
- ;;; Configuration variables
- (defgroup org-cite nil
- "Options concerning citations in Org mode."
- :group 'org
- :tag "Org Cite")
- (defcustom org-cite-global-bibliography nil
- "List of bibliography files available in all documents.
- File names must be absolute."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "No global bibliography" nil)
- (repeat :tag "List of bibliography files"
- (file :tag "Bibliography"))))
- (defcustom org-cite-activate-processor 'basic
- "Processor used for activating citations, as a symbol."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "Default fontification" nil)
- (symbol :tag "Citation processor")))
- (defcustom org-cite-export-processors '((t basic))
- "Processor used for exporting citations, as a triplet, or nil.
- When nil, citations and bibliography are not exported.
- When non-nil, the value is an association list between export back-ends and
- citation export processors:
- (BACK-END . PROCESSOR)
- where BACK-END is the name of an export back-end or t, and PROCESSOR is a
- triplet following the pattern
- (NAME BIBLIOGRAPHY-STYLE CITATION-STYLE)
- There, NAME is the name of a registered citation processor providing export
- functionality, as a symbol. BIBLIOGRAPHY-STYLE (respectively CITATION-STYLE)
- is the desired default style to use when printing a bibliography (respectively
- exporting a citation), as a string or nil. Both BIBLIOGRAPHY-STYLE and
- CITATION-STYLE are optional. NAME is mandatory.
- The export process selects the citation processor associated to the current
- export back-end, or the most specific back-end the current one is derived from,
- or, if all are inadequate, to the processor associated to t. For example, with
- the following value
- ((beamer natbib)
- (latex biblatex)
- (t csl))
- exporting with `beamer' or any back-end derived from it will use `natbib',
- whereas exporting with `latex' or any back-end derived from it but different
- from `beamer' will use `biblatex' processor. Any other back-end, such as
- `html', will use `csl' processor.
- CITATION-STYLE is overridden by adding a style to any citation object. A nil
- style lets the export processor choose the default output. Any style not
- recognized by the export processor is equivalent to nil.
- The citation triplet can also be set with the CITE_EXPORT keyword.
- E.g.,
- #+CITE_EXPORT: basic note numeric
- or
- #+CITE_EXPORT: basic
- In that case, `basic' processor is used on every export, independently on the
- back-end."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "No export" nil)
- (alist :key-type symbol
- :value-type
- (list :tag "Citation processor"
- (symbol :tag "Processor name")
- (choice
- (const :tag "Default bibliography style" nil)
- (string :tag "Use specific bibliography style"))
- (choice
- (const :tag "Default citation style" nil)
- (string :tag "Use specific citation style"))))))
- (defcustom org-cite-follow-processor 'basic
- "Processor used for following citations, as a symbol."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "No following" nil)
- (symbol :tag "Citation processor")))
- (defcustom org-cite-insert-processor 'basic
- "Processor used for inserting citations, as a symbol."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "No insertion" nil)
- (symbol :tag "Citation processor")))
- (defcustom org-cite-adjust-note-numbers t
- "When non-nil, allow process to modify location of note numbers.
- When this variable is non-nil, it is possible to swap between author-date and
- note style without modifying the document. To that effect, citations should
- always be located as in an author-date style. Prior to turning the citation
- into a footnote, the citation processor moves the citation (i.e., the future
- note number), and the surrounding punctuation, according to rules defined in
- `org-cite-note-rules'.
- When nil, the note number is not moved."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(choice (const :tag "Automatic note number location" t)
- (const :tag "Place note numbers manually" nil))
- :safe #'booleanp)
- (defcustom org-cite-note-rules
- '(("en-us" inside outside after)
- ("fr" adaptive same before))
- "Alist between languages and typographic rules for citations in note style.
- When `org-cite-adjust-note-numbers' is non-nil, and note style is requested,
- citation processor is allowed to move the note marker according to some specific
- rules, detailed here. More accurately, a rule is a list following the pattern
- (LANGUAGE-TAG . RULE)
- LANGUAGE-TAG is a down-cased string representing a language tag as defined in
- RFC 4646. It may constituted of a language and a region separated with an
- hyphen (e.g., \"en-us\"), or the language alone (e.g., \"fr\"). A language
- without a region applies to all regions.
- RULE is a triplet
- (PUNCTUATION NUMBER ORDER)
- PUNCTUATION is the desired location of the punctuation with regards to the
- quotation, if any. It may be `inside', `outside', or `adaptive'. The latter
- permits subtler control over the punctuation: when there is no space between
- the quotation mark and the punctuation, it is equivalent to `inside'.
- Otherwise, it means `outside', as illustrated in the following examples:
- \"A quotation ending without punctuation\" [cite:@org21].
- \"A quotation ending with a period\"[cite:@org21].
- Notwithstanding the above, a space always appear before the citation when it
- is to become anything else than a note.
- NUMBER is the desired location of the note number with regards to the
- quotation mark, if any. It may be `inside', `outside', or `same'. When set
- to `same', the number appears on the same side as the punctuation, unless
- there is punctuation on both sides or on none.
- ORDER is the relative position of the citation with regards to the closest
- punctuation. It may be `after' or `before'.
- For example (adaptive same before) corresponds to French typography.
- When the locale is unknown to this variable, the default rule is:
- (adaptive outside after)
- This roughly follows the Oxford Guide to Style recommendations."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type
- '(repeat
- (list :tag "Typographic rule"
- (string :tag "Language code")
- (choice :tag "Location of punctuation"
- (const :tag "Punctuation inside quotation" inside)
- (const :tag "Punctuation outside quotation" outside)
- (const :tag "Location depends on spacing" adaptive))
- (choice :tag "Location of citation"
- (const :tag "Citation inside quotation" inside)
- (const :tag "Citation outside quotation" outside)
- (const :tag "Citation next to punctuation" same))
- (choice :tag "Order of citation and punctuation"
- (const :tag "Citation first" before)
- (const :tag "Citation last" after)))))
- (defcustom org-cite-punctuation-marks '("." "," ";" ":" "!" "?")
- "List of strings that can be moved around when placing note numbers.
- When `org-cite-adjust-note-numbers' is non-nil, the citation processor is
- allowed to shuffle punctuation marks specified in this list in order to
- place note numbers according to rules defined in `org-cite-note-rules'."
- :group 'org-cite
- :package-version '(Org . "9.5")
- :type '(repeat string))
- ;;; Citation processors
- (cl-defstruct (org-cite-processor (:constructor org-cite--make-processor)
- (:copier nil))
- (name nil :read-only t)
- (activate nil :read-only t)
- (cite-styles nil :read-only t)
- (export-bibliography nil :read-only t)
- (export-citation nil :read-only t)
- (export-finalizer nil :read-only t)
- (follow nil :read-only t)
- (insert nil :read-only t))
- (defvar org-cite--processors nil
- "List of registered citation processors.
- See `org-cite-register-processor' for more information about
- processors.")
- (defun org-cite-register-processor (name &rest body)
- "Mark citation processor NAME as available.
- NAME is a symbol. BODY is a property list, where the following
- optional keys can be set:
- `:activate'
- Function activating a citation. It is called with a single
- argument: a citation object extracted from the current
- buffer. It may add text properties to the buffer. If it is
- not provided, `org-cite-fontify-default' is used.
- `:export-bibliography'
- Function rendering a bibliography. It is called with six
- arguments: the list of citation keys used in the document, as
- strings, a list of bibliography files, the style, as a string
- or nil, the local properties, as a property list, the export
- back-end, as a symbol, and the communication channel, as a
- property list.
- It is called at each \"print_bibliography\" keyword in the
- parse tree. It may return a string, a parsed element, a list
- of parsed elements, or nil. When it returns nil, the keyword
- is ignored. Otherwise, the value it returns replaces the
- keyword in the export output.
- `:export-citation' (mandatory for \"export\" capability)
- Function rendering citations. It is called with four
- arguments: a citation object, the style, as a pair, the
- export back-end, as a symbol, and the communication channel,
- as a property list.
- It is called on each citation object in the parse tree. It
- may return a string, a parsed object, a secondary string, or
- nil. When it returns nil, the citation is ignored.
- Otherwise, the value it returns replaces the citation object
- in the export output.
- `:export-finalizer'
- Function called at the end of export process. It must accept
- six arguments: the output, as a string, a list of citation
- keys used in the document, a list of bibliography files, the
- expected bibliography style, as a string or nil, the export
- back-end, as a symbol, and the communication channel, as a
- property list.
- It must return a string, which will become the final output
- from the export process, barring subsequent modifications
- from export filters.
- `:follow'
- Function called to follow a citation. It accepts two
- arguments, the citation or citation reference object at
- point, and any prefix argument received during interactive
- call of `org-open-at-point'.
- `:insert'
- Function called to insert a citation. It accepts two
- arguments, the citation or citation reference object at point
- or nil, and any prefix argument received.
- `:cite-styles'
- When the processor has export capability, the value can
- specify what cite styles, variants, and their associated
- shortcuts are supported. It can be useful information for
- completion or linting.
- The expected format is
- ((STYLE . SHORTCUTS) . VARIANTS))
- where STYLE is a string, SHORTCUTS a list of strings or nil,
- and VARIANTS is a list of pairs (VARIANT . SHORTCUTS),
- VARIANT being a string and SHORTCUTS a list of strings or
- nil.
- The \"nil\" style denotes the processor fall-back style. It
- should have a corresponding entry in the value.
- The value can also be a function. It will be called without
- any argument and should return a list structured as the above.
- Return a non-nil value on a successful operation."
- (declare (indent 1))
- (unless (and name (symbolp name))
- (error "Invalid processor name: %S" name))
- (setq org-cite--processors
- (cons (apply #'org-cite--make-processor :name name body)
- (seq-remove (lambda (p) (eq name (org-cite-processor-name p)))
- org-cite--processors))))
- (defun org-cite-try-load-processor (name)
- "Try loading citation processor NAME if unavailable.
- NAME is a symbol. When the NAME processor is unregistered, try
- loading \"oc-NAME\" library beforehand, then cross fingers."
- (unless (org-cite-get-processor name)
- (require (intern (format "oc-%s" name)) nil t)))
- (defun org-cite-get-processor (name)
- "Return citation processor named after symbol NAME.
- Return nil if no such processor is found."
- (seq-find (lambda (p) (eq name (org-cite-processor-name p)))
- org-cite--processors))
- (defun org-cite-unregister-processor (name)
- "Unregister citation processor NAME.
- NAME is a symbol. Raise an error if processor is not registered.
- Return a non-nil value on a successful operation."
- (unless (and name (symbolp name))
- (error "Invalid processor name: %S" name))
- (pcase (org-cite-get-processor name)
- ('nil (error "Processor %S not registered" name))
- (processor
- (setq org-cite--processors (delete processor org-cite--processors))))
- t)
- (defun org-cite-processor-has-capability-p (processor capability)
- "Return non-nil if PROCESSOR is able to handle CAPABILITY.
- PROCESSOR is the name of a cite processor, as a symbol. CAPABILITY is
- `activate', `export', `follow', or `insert'."
- (let ((p (org-cite-get-processor processor)))
- (pcase capability
- ((guard (not p)) nil) ;undefined processor
- ('activate (functionp (org-cite-processor-activate p)))
- ('export (functionp (org-cite-processor-export-citation p)))
- ('follow (functionp (org-cite-processor-follow p)))
- ('insert (functionp (org-cite-processor-insert p)))
- (other (error "Invalid capability: %S" other)))))
- ;;; Internal functions
- (defun org-cite--set-post-blank (datum blanks)
- "Set `:post-blank' property from element or object before DATUM to BLANKS.
- DATUM is an element or object. BLANKS is an integer. DATUM is modified
- by side-effect."
- (if (not (eq 'plain-text (org-element-type datum)))
- (org-element-put-property datum :post-blank blanks)
- ;; Remove any blank from string before DATUM so it is exported
- ;; with exactly BLANKS white spaces.
- (org-element-set-element
- datum
- (replace-regexp-in-string
- "[ \t\n]*\\'" (make-string blanks ?\s) datum))))
- (defun org-cite--set-previous-post-blank (datum blanks info)
- "Set `:post-blank' property from element or object before DATUM to BLANKS.
- DATUM is an element or object. BLANKS is an integer. INFO is the export
- state, as a property list. Previous element or object, if any, is modified by
- side-effect."
- (let ((previous (org-export-get-previous-element datum info)))
- (when previous
- (org-cite--set-post-blank previous blanks))))
- (defun org-cite--insert-at-split (s citation n regexp)
- "Split string S and insert CITATION object between the two parts.
- S is split at beginning of match group N upon matching REGEXP against it.
- This function assumes S precedes CITATION."
- ;; When extracting the citation, remove white spaces before it, but
- ;; preserve those after it.
- (let ((post-blank (org-element-property :post-blank citation)))
- (when (and post-blank (> post-blank 0))
- (org-element-insert-before (make-string post-blank ?\s) citation)))
- (org-element-insert-before
- (org-element-put-property (org-element-extract-element citation)
- :post-blank 0)
- s)
- (string-match regexp s)
- (let* ((split (match-beginning n))
- (first-part (substring s nil split))
- ;; Remove trailing white spaces as they are before the
- ;; citation.
- (last-part
- (replace-regexp-in-string (rx (1+ (any blank ?\n)) string-end)
- ""
- (substring s split))))
- (when (org-string-nw-p first-part)
- (org-element-insert-before first-part citation))
- (org-element-set-element s last-part)))
- (defun org-cite--move-punct-before (punct citation s info)
- "Move punctuation PUNCT before CITATION object.
- String S contains PUNCT. INFO is the export state, as a property list.
- The function assumes S follows CITATION. Parse tree is modified by side-effect."
- (if (equal s punct)
- (org-element-extract-element s) ;it would be empty anyway
- (org-element-set-element s (substring s (length punct))))
- ;; Remove blanks before citation.
- (org-cite--set-previous-post-blank citation 0 info)
- (org-element-insert-before
- ;; Blanks between citation and punct are now before punct and
- ;; citation.
- (concat (make-string (or (org-element-property :post-blank citation) 0) ?\s)
- punct)
- citation))
- (defun org-cite--parse-as-plist (s)
- "Parse string S as a property list.
- Values are always strings. Return nil if S is nil."
- (cond
- ((null s) nil)
- ((stringp s)
- (with-temp-buffer
- (save-excursion (insert s))
- (skip-chars-forward " \t")
- (let ((results nil)
- (value-flag nil))
- (while (not (eobp))
- (pcase (char-after)
- (?:
- (push (read (current-buffer)) results)
- (setq value-flag t))
- ((guard (not value-flag))
- (skip-chars-forward "^ \t"))
- (?\"
- (let ((origin (point)))
- (condition-case _
- (progn
- (read (current-buffer))
- (push (buffer-substring (1+ origin) (1- (point))) results))
- (end-of-file
- (goto-char origin)
- (skip-chars-forward "^ \t")
- (push (buffer-substring origin (point)) results)))
- (setq value-flag nil)))
- (_
- (let ((origin (point)))
- (skip-chars-forward "^ \t")
- (push (buffer-substring origin (point)) results)
- (setq value-flag nil))))
- (skip-chars-forward " \t"))
- (nreverse results))))
- (t (error "Invalid argument type: %S" s))))
- (defun org-cite--get-note-rule (info)
- "Return punctuation rule according to language used for export.
- INFO is the export state, as a property list.
- Rule is found according to the language used for export and
- `org-cite-note-rules', which see.
- If there is no rule matching current language, the rule defaults
- to (adaptive outside after)."
- (let* ((language-tags
- ;; Normalize language as a language-region tag, as described
- ;; in RFC 4646.
- (pcase (split-string (plist-get info :language) "[-_]")
- (`(,language)
- (list language
- (or (cdr (assoc language org-cite--default-region-alist))
- language)))
- (`(,language ,region)
- (list language region))
- (other
- (error "Invalid language identifier: %S" other))))
- (language-region (mapconcat #'downcase language-tags "-"))
- (language (car language-tags)))
- (or (cdr (assoc language-region org-cite-note-rules))
- (cdr (assoc language org-cite-note-rules))
- '(adaptive outside after))))
- ;;; Generic tools
- (defun org-cite-list-bibliography-files ()
- "List all bibliography files defined in the buffer."
- (delete-dups
- (append (mapcar (lambda (value)
- (pcase value
- (`(,f . ,d)
- (expand-file-name (org-strip-quotes f) d))))
- (pcase (org-collect-keywords
- '("BIBLIOGRAPHY") nil '("BIBLIOGRAPHY"))
- (`(("BIBLIOGRAPHY" . ,pairs)) pairs)))
- org-cite-global-bibliography)))
- (defun org-cite-get-references (citation &optional keys-only)
- "Return citations references contained in CITATION object.
- When optional argument KEYS-ONLY is non-nil, return the references' keys, as a
- list of strings.
- Assume CITATION object comes from either a full parse tree, e.g., during export,
- or from the current buffer."
- (let ((contents (org-element-contents citation)))
- (cond
- ((null contents)
- (org-with-point-at (org-element-property :contents-begin citation)
- (narrow-to-region (point) (org-element-property :contents-end citation))
- (let ((references nil))
- (while (not (eobp))
- (let ((reference (org-element-citation-reference-parser)))
- (goto-char (org-element-property :end reference))
- (push (if keys-only
- (org-element-property :key reference)
- reference)
- references)))
- (nreverse references))))
- (keys-only (mapcar (lambda (r) (org-element-property :key r)) contents))
- (t contents))))
- (defun org-cite-boundaries (citation)
- "Return the beginning and end strict position of CITATION.
- Returns a (BEG . END) pair."
- (let ((beg (org-element-property :begin citation))
- (end (org-with-point-at (org-element-property :end citation)
- (skip-chars-backward " \t")
- (point))))
- (cons beg end)))
- (defun org-cite-key-boundaries (reference)
- "Return citation REFERENCE's key boundaries as buffer positions.
- The function returns a pair (START . END) where START and END denote positions
- in the current buffer. Positions include leading \"@\" character."
- (org-with-point-at (org-element-property :begin reference)
- (let ((end (org-element-property :end reference)))
- (re-search-forward org-element-citation-key-re end t)
- (cons (match-beginning 0) (match-end 0)))))
- (defun org-cite-main-affixes (citation)
- "Return main affixes for CITATION object.
- Some export back-ends only support a single pair of affixes per
- citation, even if it contains multiple keys. This function
- decides what affixes are the most appropriate.
- Return a pair (PREFIX . SUFFIX) where PREFIX and SUFFIX are
- parsed data."
- (let ((source
- ;; When there are multiple references, use global affixes.
- ;; Otherwise, local affixes have priority.
- (pcase (org-cite-get-references citation)
- (`(,reference) reference)
- (_ citation))))
- (cons (org-element-property :prefix source)
- (org-element-property :suffix source))))
- (defun org-cite-supported-styles (&optional processors)
- "List of supported citation styles and variants.
- Supported styles are those handled by export processors from
- `org-cite-export-processors', or in PROCESSORS, as a list of symbols,
- when non-nil.
- Return value is a list with the following items:
- ((STYLE . SHORTCUTS) . VARIANTS))
- where STYLE is a string, SHORTCUTS a list of strings, and VARIANTS is a list of
- pairs (VARIANT . SHORTCUTS), VARIANT being a string and SHORTCUTS a list of
- strings."
- (let ((collection
- (seq-mapcat
- (lambda (name)
- (pcase (org-cite-processor-cite-styles
- (org-cite-get-processor name))
- ((and (pred functionp) f) (funcall f))
- (static-data static-data)))
- (or processors
- (mapcar (pcase-lambda (`(,_ . (,name . ,_))) name)
- org-cite-export-processors))))
- (result nil))
- ;; Merge duplicate styles. Each style full name is guaranteed to
- ;; be unique, and associated to all shortcuts and all variants in
- ;; the initial collection.
- (pcase-dolist (`((,style . ,shortcuts) . ,variants) collection)
- (let ((entry (assoc style result)))
- (if (not entry)
- (push (list style shortcuts variants) result)
- (setf (nth 1 entry)
- (seq-uniq (append shortcuts (nth 1 entry))))
- (setf (nth 2 entry)
- (append variants (nth 2 entry))))))
- ;; Return value with the desired format.
- (nreverse
- (mapcar (pcase-lambda (`(,style ,shortcuts ,variants))
- (cons (cons style (nreverse shortcuts))
- ;; Merge variant shortcuts.
- (let ((result nil))
- (pcase-dolist (`(,variant . ,shortcuts) variants)
- (let ((entry (assoc variant result)))
- (if (not entry)
- (push (cons variant shortcuts) result)
- (setf (cdr entry)
- (seq-uniq (append shortcuts (cdr entry)))))))
- result)))
- result))))
- (defun org-cite-delete-citation (datum)
- "Delete citation or citation reference DATUM.
- When removing the last reference, also remove the whole citation."
- (pcase (org-element-type datum)
- ('citation
- (pcase-let* ((`(,begin . ,end) (org-cite-boundaries datum))
- (pos-before-blank
- (org-with-point-at begin
- (skip-chars-backward " \t")
- (point)))
- (pos-after-blank (org-element-property :end datum))
- (first-on-line?
- (= pos-before-blank (line-beginning-position)))
- (last-on-line?
- (= pos-after-blank (line-end-position))))
- (cond
- ;; The citation is alone on its line. Remove the whole line.
- ;; Do not leave it blank as it might break a surrounding
- ;; paragraph.
- ((and first-on-line? last-on-line?)
- (delete-region (line-beginning-position) (line-beginning-position 2)))
- ;; When the citation starts the line, preserve indentation.
- (first-on-line? (delete-region begin pos-after-blank))
- ;; When the citation ends the line, remove any trailing space.
- (last-on-line? (delete-region pos-before-blank (line-end-position)))
- ;; Otherwise, delete blanks before the citation.
- ;; Nevertheless, make sure there is at least one blank left,
- ;; so as to not splice unrelated surroundings.
- (t
- (delete-region pos-before-blank end)
- (when (= pos-after-blank end)
- (org-with-point-at pos-before-blank (insert " ")))))))
- ('citation-reference
- (let* ((citation (org-element-property :parent datum))
- (references (org-cite-get-references citation))
- (begin (org-element-property :begin datum))
- (end (org-element-property :end datum)))
- (cond
- ;; Single reference.
- ((= 1 (length references))
- (org-cite-delete-citation citation))
- ;; First reference, no prefix.
- ((and (= begin (org-element-property :contents-begin citation))
- (not (org-element-property :prefix citation)))
- (org-with-point-at (org-element-property :begin datum)
- (skip-chars-backward " \t")
- (delete-region (point) end)))
- ;; Last reference, no suffix.
- ((and (= end (org-element-property :contents-end citation))
- (not (org-element-property :suffix citation)))
- (delete-region (1- begin) (1- (cdr (org-cite-boundaries citation)))))
- ;; Somewhere in-between.
- (t
- (delete-region begin end)))))
- (other
- (error "Invalid object type: %S" other))))
- ;;; Tools only available during export
- (defun org-cite-citation-style (citation info)
- "Return citation style used for CITATION object.
- Style is a pair (NAME . VARIANT) where NAME and VARIANT are strings or nil.
- A nil NAME means the default style for the current processor should be used.
- INFO is a plist used as a communication channel."
- (let* ((separate
- (lambda (s)
- (cond
- ((null s) (cons nil nil))
- ((not (string-match "/" s)) (cons s nil))
- (t (cons (substring s nil (match-beginning 0))
- (org-string-nw-p (substring s (match-end 0))))))))
- (local (funcall separate (org-element-property :style citation)))
- (global
- (funcall separate (pcase (plist-get info :cite-export)
- (`(,_ ,_ ,style) style)
- (_ nil)))))
- (cond
- ((org-string-nw-p (car local))
- (cons (org-not-nil (car local)) (cdr local)))
- (t
- (cons (org-not-nil (car global))
- (or (cdr local) (cdr global)))))))
- (defun org-cite-read-processor-declaration (s)
- "Read processor declaration from string S.
- Return (NAME BIBLIOGRAPHY-STYLE CITATION-STYLE) triplet, when
- NAME is the processor name, as a symbol, and both
- BIBLIOGRAPHY-STYLE and CITATION-STYLE are strings or nil. Those
- strings may contain spaces if they are enclosed within double
- quotes.
- String S is expected to contain between 1 and 3 tokens. The
- function raises an error when it contains too few or too many
- tokens. Spurious spaces are ignored."
- (with-temp-buffer
- (save-excursion (insert s))
- (let ((result (list (read (current-buffer)))))
- (dotimes (_ 2)
- (skip-chars-forward " \t")
- (cond
- ((eobp) (push nil result))
- ((char-equal ?\" (char-after))
- (push (org-not-nil (read (current-buffer)))
- result))
- (t
- (let ((origin (point)))
- (skip-chars-forward "^ \t")
- (push (org-not-nil (buffer-substring origin (point)))
- result)))))
- (skip-chars-forward " \t")
- (unless (eobp)
- (error "Trailing garbage following cite export processor declaration %S"
- s))
- (nreverse result))))
- (defun org-cite-bibliography-style (info)
- "Return expected bibliography style.
- INFO is a plist used as a communication channel."
- (pcase (plist-get info :cite-export)
- (`(,_ ,style ,_) style)
- (_ nil)))
- (defun org-cite-bibliography-properties (keyword)
- "Return properties associated to \"print_bibliography\" KEYWORD object.
- Return value is a property list."
- (org-cite--parse-as-plist (org-element-property :value keyword)))
- (defun org-cite-list-citations (info)
- "List citations in the exported document.
- Citations are ordered by appearance in the document, when following footnotes.
- INFO is the export communication channel, as a property list."
- (or (plist-get info :citations)
- (letrec ((cites nil)
- (tree (plist-get info :parse-tree))
- (definition-cache (make-hash-table :test #'equal))
- (definition-list nil)
- (find-definition
- ;; Find definition for standard reference LABEL. At
- ;; this point, it is impossible to rely on
- ;; `org-export-get-footnote-definition' because the
- ;; function caches results that could contain
- ;; un-processed citation objects. So we use
- ;; a simplified version of the function above.
- (lambda (label)
- (or (gethash label definition-cache)
- (org-element-map
- (or definition-list
- (setq definition-list
- (org-element-map
- tree
- 'footnote-definition
- #'identity info)))
- 'footnote-definition
- (lambda (d)
- (and (equal label (org-element-property :label d))
- (puthash label
- (or (org-element-contents d) "")
- definition-cache)))
- info t))))
- (search-cites
- (lambda (data)
- (org-element-map data '(citation footnote-reference)
- (lambda (datum)
- (pcase (org-element-type datum)
- ('citation (push datum cites))
- ;; Do not force entering inline definitions, since
- ;; `org-element-map' is going to enter it anyway.
- ((guard (eq 'inline (org-element-property :type datum))))
- ;; Walk footnote definition.
- (_
- (let ((label (org-element-property :label datum)))
- (funcall search-cites
- (funcall find-definition label)))))
- nil)
- info nil 'footnote-definition t))))
- (funcall search-cites tree)
- (let ((result (nreverse cites)))
- (plist-put info :citations result)
- result))))
- (defun org-cite-list-keys (info)
- "List citation keys in the exported document.
- Keys are ordered by first appearance in the document, when following footnotes.
- Duplicate keys are removed. INFO is the export communication channel, as a
- property list."
- (delete-dups
- (org-element-map (org-cite-list-citations info) 'citation-reference
- (lambda (r) (org-element-property :key r))
- info)))
- (defun org-cite-key-number (key info &optional predicate)
- "Return number associated to string KEY.
- INFO is the export communication channel, as a property list.
- Optional argument PREDICATE is called with two keys, and returns non-nil
- if the first reference should sort before the second. When nil, references
- are sorted in order cited."
- (let* ((keys (org-cite-list-keys info))
- (sorted-keys (if (functionp predicate)
- (sort keys predicate)
- keys))
- (position (seq-position sorted-keys key #'string-equal)))
- (and (integerp position)
- (1+ position))))
- (defun org-cite-inside-footnote-p (citation &optional strict)
- "Non-nil when CITATION object is contained within a footnote.
- When optional argument STRICT is non-nil, return t only if CITATION represents
- the sole contents of the footnote, e.g., after calling `org-cite-wrap-citation'.
- When non-nil, the return value if the footnote container."
- (let ((footnote
- (org-element-lineage citation
- '(footnote-definition footnote-reference))))
- (and footnote
- (or (not strict)
- (equal (org-element-contents (org-element-property :parent citation))
- (list citation)))
- ;; Return value.
- footnote)))
- (defun org-cite-wrap-citation (citation info)
- "Wrap an anonymous inline footnote around CITATION object in the parse tree.
- INFO is the export state, as a property list.
- White space before the citation, if any, are removed. The parse tree is
- modified by side-effect.
- Return newly created footnote object."
- (let ((footnote
- (list 'footnote-reference
- (list :label nil
- :type 'inline
- :contents-begin (org-element-property :begin citation)
- :contents-end (org-element-property :end citation)
- :post-blank (org-element-property :post-blank citation)))))
- ;; Remove any white space before citation.
- (org-cite--set-previous-post-blank citation 0 info)
- ;; Footnote swallows citation.
- (org-element-insert-before footnote citation)
- (org-element-adopt-elements footnote
- (org-element-extract-element citation))))
- (defun org-cite-adjust-note (citation info &optional rule punct)
- "Adjust note number location for CITATION object, and punctuation around it.
- INFO is the export state, as a property list.
- Optional argument RULE is the punctuation rule used, as a triplet. When nil,
- rule is determined according to `org-cite-note-rules', which see.
- Optional argument PUNCT is a list of punctuation marks to be considered.
- When nil, it defaults to `org-cite-punctuation-marks'.
- Parse tree is modified by side-effect.
- Note: when calling both `org-cite-adjust-note' and `org-cite-wrap-citation' on
- the same object, call `org-cite-adjust-note' first."
- (when org-cite-adjust-note-numbers
- (pcase-let* ((rule (or rule (org-cite--get-note-rule info)))
- (punct-re (regexp-opt (or punct org-cite-punctuation-marks)))
- ;; with Emacs <27.1. Argument of `regexp' form (PUNCT-RE this case)
- ;; must be a string literal.
- (previous-punct-re
- (rx-to-string `(seq (opt (group (regexp ,(rx (0+ (any blank ?\n))))
- (regexp ,punct-re)))
- (regexp ,(rx (opt (0+ (any blank ?\n)) (group ?\"))
- (opt (group (1+ (any blank ?\n))))
- string-end)))
- t))
- (next-punct-re
- (rx-to-string `(seq string-start
- (group (0+ (any blank ?\n)) (regexp ,punct-re)))
- t))
- (next (org-export-get-next-element citation info))
- (final-punct
- (and (stringp next)
- (string-match next-punct-re next)
- (match-string 1 next)))
- (previous
- ;; Find the closest terminal object. Consider
- ;; citation, subscript and superscript objects as
- ;; terminal.
- (org-last
- (org-element-map (org-export-get-previous-element citation info)
- '(citation code entity export-snippet footnote-reference
- line-break latex-fragment link plain-text
- radio-target statistics-cookie timestamp
- verbatim)
- #'identity info nil '(citation subscript superscript))))
- (`(,punct ,quote ,spacing)
- (and (stringp previous)
- (string-match previous-punct-re previous)
- (list (match-string 1 previous)
- (match-string 2 previous)
- (match-string 3 previous)))))
- ;; Bail you when there is no quote and either no punctuation, or
- ;; punctuation on both sides.
- (when (or quote (org-xor punct final-punct))
- ;; Phase 1: handle punctuation rule.
- (pcase rule
- ((guard (not quote)) nil)
- ;; Move punctuation inside.
- (`(,(or `inside (and `adaptive (guard (not spacing)))) . ,_)
- ;; This only makes sense if there is a quotation before the
- ;; citation that does not end with some punctuation.
- (when (and (not punct) final-punct)
- ;; Quote guarantees there is a string object before
- ;; citation. Likewise, any final punctuation guarantees
- ;; there is a string object following citation.
- (let ((new-prev
- (replace-regexp-in-string
- previous-punct-re
- (concat final-punct "\"") previous nil nil 2))
- (new-next
- (replace-regexp-in-string
- ;; Before Emacs-27.1 `literal' `rx' form with a variable
- ;; as an argument is not available.
- (rx-to-string `(seq string-start ,final-punct) t)
- "" next)))
- (org-element-set-element previous new-prev)
- (org-element-set-element next new-next)
- (setq previous new-prev)
- (setq next new-next)
- (setq punct final-punct)
- (setq final-punct nil))))
- ;; Move punctuation outside.
- (`(,(or `outside (and `adaptive (guard spacing))) . ,_)
- ;; This is only meaningful if there is some inner
- ;; punctuation and no final punctuation already.
- (when (and punct (not final-punct))
- ;; Inner punctuation guarantees there is text object
- ;; before the citation. However, there is no information
- ;; about the object following citation, if any.
- ;; Therefore, we handle all the possible cases (string,
- ;; other type, or none).
- (let ((new-prev
- (replace-regexp-in-string
- previous-punct-re "" previous nil nil 1))
- (new-next (if (stringp next) (concat punct next) punct)))
- (org-element-set-element previous new-prev)
- (cond
- ((stringp next)
- (org-element-set-element next new-next))
- (next
- (org-element-insert-before new-next next))
- (t
- (org-element-adopt-elements
- (org-element-property :parent citation)
- new-next)))
- (setq previous new-prev)
- (setq next new-next)
- (setq final-punct punct)
- (setq punct nil))))
- (_
- (error "Invalid punctuation rule: %S" rule))))
- ;; Phase 2: move citation to its appropriate location.
- ;;
- ;; First transform relative citation location into a definitive
- ;; location, according to the surrounding punctuation.
- (pcase rule
- (`(,punctuation same ,order)
- (setf rule
- (list punctuation
- (cond
- ;; When there is punctuation on both sides, the
- ;; citation is necessarily on the outside.
- ((and punct final-punct) 'outside)
- (punct 'inside)
- (final-punct 'outside)
- ;; No punctuation: bail out on next step.
- (t nil))
- order))))
- (pcase rule
- (`(,_ nil ,_) nil)
- (`(,_ inside after)
- ;; Citation has to be moved after punct, if there is
- ;; a quotation mark, or after final punctuation.
- (cond
- (quote
- (org-cite--insert-at-split previous citation 2 previous-punct-re))
- (final-punct
- (org-cite--move-punct-before final-punct citation next info))
- ;; There is only punct, and we're already after it.
- (t nil)))
- (`(,_ inside before)
- ;; Citation is already behind final-punct, so only consider
- ;; other locations.
- (when (or punct quote)
- (org-cite--insert-at-split previous citation 0 previous-punct-re)))
- (`(,_ outside after)
- ;; Citation is already after any punct or quote. It can only
- ;; move past final punctuation, if there is one.
- (when final-punct
- (org-cite--move-punct-before final-punct citation next info)))
- (`(,_ outside before)
- ;; The only non-trivial case is when citation follows punct
- ;; without a quote.
- (when (and punct (not quote))
- (org-cite--insert-at-split previous citation 0 previous-punct-re)))
- (_
- (error "Invalid punctuation rule: %S" rule))))))
- ;;; Tools generating or operating on parsed data
- (defun org-cite-parse-elements (s)
- "Parse string S as a list of Org elements.
- The return value is suitable as a replacement for a
- \"print_bibliography\" keyword. As a consequence, the function
- raises an error if S contains a headline."
- (with-temp-buffer
- (insert s)
- (pcase (org-element-contents (org-element-parse-buffer))
- ('nil nil)
- (`(,(and section (guard (eq 'section (org-element-type section)))))
- (org-element-contents section))
- (_
- (error "Headlines cannot replace a keyword")))))
- (defun org-cite-parse-objects (s &optional affix)
- "Parse string S as a secondary string.
- The return value is suitable as a replacement for a citation object.
- When optional argument AFFIX is non-nil, restrict the set of allowed object
- types to match the contents of a citation affix."
- (org-element-parse-secondary-string
- s (org-element-restriction (if affix 'citation-reference 'paragraph))))
- (defun org-cite-make-paragraph (&rest data)
- "Return a paragraph element containing DATA.
- DATA are strings, objects or secondary strings."
- (apply #'org-element-create 'paragraph nil (apply #'org-cite-concat data)))
- (defun org-cite-emphasize (type &rest data)
- "Apply emphasis TYPE on DATA.
- TYPE is a symbol among `bold', `italic', `strike-through' and `underline'.
- DATA are strings, objects or secondary strings. Return an object of type TYPE."
- (declare (indent 1))
- (unless (memq type '(bold italic strike-through underline))
- (error "Wrong emphasis type: %S" type))
- (apply #'org-element-create type nil (apply #'org-cite-concat data)))
- (defun org-cite-concat (&rest data)
- "Concatenate all the DATA arguments and make the result a secondary string.
- Each argument may be a string, an object, or a secondary string."
- (let ((results nil))
- (dolist (datum (reverse data))
- (pcase datum
- ('nil nil)
- ;; Element or object.
- ((pred org-element-type) (push datum results))
- ;; Secondary string.
- ((pred consp) (setq results (append datum results)))
- (_
- (signal
- 'wrong-type-argument
- (list (format "Argument is not a string or a secondary string: %S"
- datum))))))
- results))
- (defun org-cite-mapconcat (function data separator)
- "Apply FUNCTION to each element of DATA, and return a secondary string.
- In between each pair of results, stick SEPARATOR, which may be a string,
- an object, or a secondary string. FUNCTION must be a function of one argument,
- and must return either a string, an object, or a secondary string."
- (and data
- (let ((result (list (funcall function (car data)))))
- (dolist (datum (cdr data))
- (setq result
- (org-cite-concat result separator (funcall function datum))))
- result)))
- ;;; Internal interface with fontification (activate capability)
- (defun org-cite-fontify-default (cite)
- "Fontify CITE with `org-cite' and `org-cite-key' faces.
- CITE is a citation object. The function applies `org-cite' face
- on the whole citation, and `org-cite-key' face on each key."
- (let ((beg (org-element-property :begin cite))
- (end (org-with-point-at (org-element-property :end cite)
- (skip-chars-backward " \t")
- (point))))
- (add-text-properties beg end '(font-lock-multiline t))
- (add-face-text-property beg end 'org-cite)
- (dolist (reference (org-cite-get-references cite))
- (let ((boundaries (org-cite-key-boundaries reference)))
- (add-face-text-property (car boundaries) (cdr boundaries)
- 'org-cite-key)))))
- (defun org-cite-activate (limit)
- "Activate citations from up to LIMIT buffer position.
- Each citation encountered is activated using the appropriate function
- from the processor set in `org-cite-activate-processor'."
- (let* ((name org-cite-activate-processor)
- (activate
- (or (and name
- (org-cite-processor-has-capability-p name 'activate)
- (org-cite-processor-activate (org-cite-get-processor name)))
- #'org-cite-fontify-default)))
- (when (re-search-forward org-element-citation-prefix-re limit t)
- (let ((cite (org-with-point-at (match-beginning 0)
- (org-element-citation-parser))))
- (when cite
- (funcall activate cite)
- ;; Move after cite object and make sure to return
- ;; a non-nil value.
- (goto-char (org-element-property :end cite)))))))
- ;;; Internal interface with Org Export library (export capability)
- (defun org-cite-store-bibliography (info)
- "Store bibliography in the communication channel.
- Bibliography is stored as a list of absolute file names in the `:bibliography'
- property.
- INFO is the communication channel, as a plist. It is modified by side-effect."
- (plist-put info :bibliography (org-cite-list-bibliography-files)))
- (defun org-cite-store-export-processor (info)
- "Store export processor in the `:cite-export' property during export.
- Export processor is stored as a triplet, or nil.
- When non-nil, it is defined as (NAME BIBLIOGRAPHY-STYLE
- CITATION-STYLE) where NAME is a symbol, whereas
- BIBLIOGRAPHY-STYLE and CITATION-STYLE are strings, or nil.
- INFO is the communication channel, as a plist. It is modified by
- side-effect."
- (let* ((err
- (lambda (s)
- (user-error "Invalid cite export processor declaration: %S" s)))
- (processor
- (pcase (plist-get info :cite-export)
- ((or "" `nil) nil)
- ;; Value is a string. It comes from a "cite_export"
- ;; keyword.
- ((and (pred stringp) s)
- (org-cite-read-processor-declaration s))
- ;; Value is an alist. It must come from
- ;; `org-cite-export-processors' variable. Find the most
- ;; appropriate processor according to current export
- ;; back-end.
- ((and (pred consp) alist)
- (let* ((backend (plist-get info :back-end))
- (candidates
- ;; Limit candidates to processors associated to
- ;; back-ends derived from or equal to the current
- ;; one.
- (sort (seq-filter
- (pcase-lambda (`(,key . ,_))
- (org-export-derived-backend-p backend key))
- alist)
- (lambda (a b)
- (org-export-derived-backend-p (car a) (car b))))))
- ;; Select the closest candidate, or fallback to t.
- (pcase (or (car candidates) (assq t alist))
- ('nil nil)
- (`(,_ . ,p)
- ;; Normalize value by turning it into a triplet.
- (pcase p
- (`(,(pred symbolp))
- (append p (list nil nil)))
- (`(,(pred symbolp) ,(pred string-or-null-p))
- (append p (list nil)))
- (`(,(pred symbolp)
- ,(pred string-or-null-p)
- ,(pred string-or-null-p))
- p)
- (_ (funcall err p))))
- (other (funcall err (cdr other))))))
- (other (funcall err other)))))
- (pcase processor
- ('nil nil)
- (`(,name . ,_)
- (org-cite-try-load-processor name)
- (cond
- ((not (org-cite-get-processor name))
- (user-error "Unknown processor %S" name))
- ((not (org-cite-processor-has-capability-p name 'export))
- (user-error "Processor %S is unable to handle citation export" name)))))
- (plist-put info :cite-export processor)))
- (defun org-cite-export-citation (citation _ info)
- "Export CITATION object according to INFO property list.
- This function delegates the export of the current citation to the
- selected citation processor."
- (pcase (plist-get info :cite-export)
- ('nil nil)
- (`(,p ,_ ,_)
- (funcall (org-cite-processor-export-citation (org-cite-get-processor p))
- citation
- (org-cite-citation-style citation info)
- (plist-get info :back-end)
- info))
- (other (error "Invalid `:cite-export' value: %S" other))))
- (defun org-cite-export-bibliography (keyword _ info)
- "Return bibliography associated to \"print_bibliography\" KEYWORD.
- BACKEND is the export back-end, as a symbol. INFO is a plist
- used as a communication channel."
- (pcase (plist-get info :cite-export)
- ('nil nil)
- (`(,p ,_ ,_)
- (let ((export-bibilography
- (org-cite-processor-export-bibliography
- (org-cite-get-processor p))))
- (when export-bibilography
- (funcall export-bibilography
- (org-cite-list-keys info)
- (plist-get info :bibliography)
- (org-cite-bibliography-style info)
- (org-cite-bibliography-properties keyword)
- (plist-get info :back-end)
- info))))
- (other (error "Invalid `:cite-export' value: %S" other))))
- (defun org-cite-process-citations (info)
- "Replace all citations in the parse tree.
- INFO is the communication channel, as a plist. Parse tree is modified
- by side-effect."
- (dolist (cite (org-cite-list-citations info))
- (let ((replacement (org-cite-export-citation cite nil info))
- (blanks (or (org-element-property :post-blank cite) 0)))
- (if (null replacement)
- ;; Before removing the citation, transfer its `:post-blank'
- ;; property to the object before, if any.
- (org-cite--set-previous-post-blank cite blanks info)
- ;; Make sure there is a space between a quotation mark and
- ;; a citation. This is particularly important when using
- ;; `adaptive' note rule. See `org-cite-note-rules'.
- (let ((previous (org-export-get-previous-element cite info)))
- (when (and (org-string-nw-p previous)
- (string-suffix-p "\"" previous))
- (org-cite--set-previous-post-blank cite 1 info)))
- (pcase replacement
- ;; String.
- ((pred stringp)
- ;; Handle `:post-blank' before replacing value.
- (let ((output (concat (org-trim replacement)
- (make-string blanks ?\s))))
- (org-element-insert-before (org-export-raw-string output) cite)))
- ;; Single element.
- (`(,(pred symbolp) . ,_)
- (org-cite--set-post-blank replacement blanks)
- (org-element-insert-before replacement cite))
- ;; Secondary string: splice objects at cite's place.
- ;; Transfer `:post-blank' to the last object.
- ((pred consp)
- (let ((last nil))
- (dolist (datum replacement)
- (setq last datum)
- (org-element-insert-before datum cite))
- (org-cite--set-post-blank last blanks)))
- (_
- (error "Invalid return value from citation export processor: %S"
- replacement))))
- (org-element-extract-element cite))))
- (defun org-cite-process-bibliography (info)
- "Replace all \"print_bibliography\" keywords in the parse tree.
- INFO is the communication channel, as a plist. Parse tree is modified
- by side effect."
- (org-element-map (plist-get info :parse-tree) 'keyword
- (lambda (keyword)
- (when (equal "PRINT_BIBLIOGRAPHY" (org-element-property :key keyword))
- (let ((replacement (org-cite-export-bibliography keyword nil info))
- (blanks (or (org-element-property :post-blank keyword) 0)))
- (pcase replacement
- ;; Before removing the citation, transfer its
- ;; `:post-blank' property to the element before, if any.
- ('nil
- (org-cite--set-previous-post-blank keyword blanks info)
- (org-element-extract-element keyword))
- ;; Handle `:post-blank' before replacing keyword with string.
- ((pred stringp)
- (let ((output (concat (org-element-normalize-string replacement)
- (make-string blanks ?\n))))
- (org-element-set-element keyword (org-export-raw-string output))))
- ;; List of elements: splice contents before keyword and
- ;; remove the latter. Transfer `:post-blank' to last
- ;; element.
- ((and `(,(pred listp) . ,_) contents)
- (let ((last nil))
- (dolist (datum contents)
- (setq last datum)
- (org-element-insert-before datum keyword))
- (org-cite--set-post-blank last blanks)
- (org-element-extract-element keyword)))
- ;; Single element: replace the keyword.
- (`(,(pred symbolp) . ,_)
- (org-cite--set-post-blank replacement blanks)
- (org-element-set-element keyword replacement))
- (_
- (error "Invalid return value from citation export processor: %S"
- replacement))))))
- info))
- (defun org-cite-finalize-export (output info)
- "Finalizer for export process.
- OUTPUT is the full output of the export process. INFO is the communication
- channel, as a property list."
- (pcase (plist-get info :cite-export)
- ('nil output)
- (`(,p ,_ ,_)
- (let ((finalizer
- (org-cite-processor-export-finalizer (org-cite-get-processor p))))
- (if (not finalizer)
- output
- (funcall finalizer
- output
- (org-cite-list-keys info)
- (plist-get info :bibliography)
- (org-cite-bibliography-style info)
- (plist-get info :back-end)
- info))))
- (other (error "Invalid `:cite-export' value: %S" other))))
- ;;; Internal interface with `org-open-at-point' (follow capability)
- (defun org-cite-follow (datum arg)
- "Follow citation or citation-reference DATUM.
- Following is done according to the processor set in `org-cite-follow-processor'.
- ARG is the prefix argument received when calling `org-open-at-point', or nil."
- (unless org-cite-follow-processor
- (user-error "No processor set to follow citations"))
- (org-cite-try-load-processor org-cite-follow-processor)
- (let ((name org-cite-follow-processor))
- (cond
- ((not (org-cite-get-processor name))
- (user-error "Unknown processor %S" name))
- ((not (org-cite-processor-has-capability-p name 'follow))
- (user-error "Processor %S cannot follow citations" name))
- (t
- (let ((follow (org-cite-processor-follow (org-cite-get-processor name))))
- (funcall follow datum arg))))))
- ;;; Meta-command for citation insertion (insert capability)
- (defun org-cite--allowed-p (context)
- "Non-nil when a citation can be inserted at point.
- CONTEXT is the element or object at point, as returned by `org-element-context'."
- (let ((type (org-element-type context)))
- (cond
- ;; No citation in attributes, except in parsed ones.
- ;;
- ;; XXX: Inserting citation in a secondary value is not allowed
- ;; yet. Is it useful?
- ((let ((post (org-element-property :post-affiliated context)))
- (and post (< (point) post)))
- (let ((case-fold-search t))
- (looking-back
- (rx-to-string
- `(seq line-start (0+ (any " \t"))
- "#+"
- (or ,@org-element-parsed-keywords)
- ":"
- (0+ nonl))
- t)
- (line-beginning-position))))
- ;; Paragraphs and blank lines at top of document are fine.
- ((memq type '(nil paragraph)))
- ;; So are contents of verse blocks.
- ((eq type 'verse-block)
- (and (>= (point) (org-element-property :contents-begin context))
- (< (point) (org-element-property :contents-end context))))
- ;; In an headline or inlinetask, point must be either on the
- ;; heading itself or on the blank lines below.
- ((memq type '(headline inlinetask))
- (or (not (org-at-heading-p))
- (and (save-excursion
- (beginning-of-line)
- (and (let ((case-fold-search t))
- (not (looking-at-p "\\*+ END[ \t]*$")))
- (let ((case-fold-search nil))
- (looking-at org-complex-heading-regexp))))
- (match-beginning 4)
- (>= (point) (match-beginning 4))
- (or (not (match-beginning 5))
- (< (point) (match-beginning 5))))))
- ;; White spaces after an object or blank lines after an element
- ;; are OK.
- ((>= (point)
- (save-excursion (goto-char (org-element-property :end context))
- (skip-chars-backward " \r\t\n")
- (if (eq (org-element-class context) 'object) (point)
- (line-beginning-position 2)))))
- ;; At the beginning of a footnote definition, right after the
- ;; label, is OK.
- ((eq type 'footnote-definition) (looking-at (rx space)))
- ;; At the start of a list item is fine, as long as the bullet is
- ;; unaffected.
- ((eq type 'item)
- (> (point) (+ (org-element-property :begin context)
- (current-indentation)
- (if (org-element-property :checkbox context)
- 5 1))))
- ;; Other elements are invalid.
- ((eq (org-element-class context) 'element) nil)
- ;; Just before object is fine.
- ((= (point) (org-element-property :begin context)))
- ;; Within recursive object too, but not in a link.
- ((eq type 'link) nil)
- ((eq type 'table-cell)
- ;; :contents-begin is not reliable on empty cells, so special
- ;; case it.
- (<= (save-excursion (skip-chars-backward " \t") (point))
- (org-element-property :contents-end context)))
- ((let ((cbeg (org-element-property :contents-begin context))
- (cend (org-element-property :contents-end context)))
- (and cbeg (>= (point) cbeg) (<= (point) cend)))))))
- (defun org-cite--insert-string-before (string reference)
- "Insert STRING before citation REFERENCE object."
- (org-with-point-at (org-element-property :begin reference)
- (insert string ";")))
- (defun org-cite--insert-string-after (string reference)
- "Insert STRING after citation REFERENCE object."
- (org-with-point-at (org-element-property :end reference)
- ;; Make sure to move forward when we're inserting at point, so the
- ;; insertion can happen multiple times.
- (if (char-equal ?\; (char-before))
- (insert-before-markers string ";")
- (insert-before-markers ";" string))))
- (defun org-cite--keys-to-citation (keys)
- "Build a citation object from a list of citation KEYS.
- Citation keys are strings without the leading \"@\"."
- (apply #'org-element-create
- 'citation
- nil
- (mapcar (lambda (k)
- (org-element-create 'citation-reference (list :key k)))
- keys)))
- (defun org-cite-make-insert-processor (select-key select-style)
- "Build a function appropriate as an insert processor.
- SELECT-KEY is a function called with one argument. When it is
- nil, the function should return a citation key as a string, or
- nil. Otherwise, the function should return a list of such keys,
- or nil. The keys should not have any leading \"@\" character.
- SELECT-STYLE is a function called with one argument, the citation
- object being edited or constructed so far. It should return
- a style string, or nil.
- The return value is a function of two arguments: CONTEXT and ARG.
- CONTEXT is either a citation reference, a citation object, or
- nil. ARG is a prefix argument.
- The generated function inserts or edits a citation at point.
- More specifically,
- On a citation reference:
- - on the prefix or right before the \"@\" character, insert
- a new reference before the current one,
- - on the suffix, insert it after the reference,
- - otherwise, update the cite key, preserving both affixes.
- When ARG is non-nil, remove the reference, possibly removing
- the whole citation if it contains a single reference.
- On a citation object:
- - on the style part, offer to update it,
- - on the global prefix, add a new reference before the first
- one,
- - on the global suffix, add a new reference after the last
- one.
- Elsewhere, insert a citation at point. When ARG is non-nil,
- offer to complete style in addition to references."
- (unless (and (functionp select-key) (functionp select-style))
- (error "Wrong argument type(s)"))
- (lambda (context arg)
- (pcase (org-element-type context)
- ;; When on a citation, check point is not on the blanks after it.
- ;; Otherwise, consider we're after it.
- ((and 'citation
- (guard
- (let ((boundaries (org-cite-boundaries context)))
- (and (< (point) (cdr boundaries))
- (> (point) (car boundaries))))))
- ;; When ARG is non-nil, delete the whole citation. Otherwise,
- ;; action depends on the point.
- (if arg
- (org-cite-delete-citation context)
- (let* ((begin (org-element-property :begin context))
- (style-end (1- (org-with-point-at begin (search-forward ":")))))
- (if (>= style-end (point))
- ;; On style part, edit the style.
- (let ((style-start (+ 5 begin))
- (style (funcall select-style)))
- (unless style (user-error "Aborted"))
- (org-with-point-at style-start
- (delete-region style-start style-end)
- (when (org-string-nw-p style) (insert "/" style))))
- ;; On an affix, insert a new reference before or after
- ;; point.
- (let* ((references (org-cite-get-references context))
- (key (concat "@" (funcall select-key nil))))
- (if (< (point) (org-element-property :contents-begin context))
- (org-cite--insert-string-before key (car references))
- (org-cite--insert-string-after key (org-last references))))))))
- ;; On a citation reference. If ARG is not nil, remove the
- ;; reference. Otherwise, action depends on the point.
- ((and 'citation-reference (guard arg)) (org-cite-delete-citation context))
- ('citation-reference
- (pcase-let* ((`(,start . ,end) (org-cite-key-boundaries context))
- (key (concat "@"
- (or (funcall select-key nil)
- (user-error "Aborted")))))
- ;; Right before the "@" character, do not replace the reference
- ;; at point, but insert a new one before it. It makes adding
- ;; a new reference at the beginning easier in the following
- ;; case: [cite:@key].
- (cond
- ((>= start (point)) (org-cite--insert-string-before key context))
- ((<= end (point)) (org-cite--insert-string-after key context))
- (t
- (org-with-point-at start
- (delete-region start end)
- (insert key))))))
- (_
- (let ((keys (funcall select-key t)))
- (unless keys (user-error "Aborted"))
- (insert
- (format "[cite%s:%s]"
- (if arg
- (let ((style (funcall select-style
- (org-cite--keys-to-citation keys))))
- (if (org-string-nw-p style)
- (concat "/" style)
- ""))
- "")
- (mapconcat (lambda (k) (concat "@" k)) keys "; "))))))))
- ;;;###autoload
- (defun org-cite-insert (arg)
- "Insert a citation at point.
- Insertion is done according to the processor set in `org-cite-insert-processor'.
- ARG is the prefix argument received when calling interactively the function."
- (interactive "P")
- (unless org-cite-insert-processor
- (user-error "No processor set to insert citations"))
- (org-cite-try-load-processor org-cite-insert-processor)
- (let ((name org-cite-insert-processor))
- (cond
- ((not (org-cite-get-processor name))
- (user-error "Unknown processor %S" name))
- ((not (org-cite-processor-has-capability-p name 'insert))
- (user-error "Processor %S cannot insert citations" name))
- (t
- (let ((context (org-element-context))
- (insert (org-cite-processor-insert (org-cite-get-processor name))))
- (cond
- ((memq (org-element-type context) '(citation citation-reference))
- (funcall insert context arg))
- ((org-cite--allowed-p context)
- (funcall insert nil arg))
- (t
- (user-error "Cannot insert a citation here"))))))))
- (provide 'oc)
- ;;; oc.el ends here
|