citeproc-style.el

;; 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.
CATEGORY is the style's category as a string,
INFO is the style's general info (currently simply the
  corresponding fragment of the parsed xml),
OPTS, BIB-OPTS, CITE-OPTS and LOCALE-OPTS are alists of general
  and bibliography-, cite- and locale-specific CSL options,
BIB-SORT, BIB-LAYOUT, CITE-SORT and CITE-LAYOUT are anonymous
  functions for calculating sort-keys and rendering,
BIB-SORT-ORDERS and CITE-SORT-ORDERS are the lists of sort orders
  for bibliography and cite sort (the value is a list containg t
  or nil as its n-th element depending on whether the sort for on
  the n-th key should be in ascending or desending order,
CITE-LAYOUT-ATTRS contains the attributes of the citation layout
  as an alist,
DATE-TEXT and DATE-NUMERIC are the style's date formats,
LOCALE contains the locale to be used or nil if not set,
MACROS is an alist with macro names as keys and corresponding
  anonymous rendering functions,
TERMS is the style's parsed term-list,
USES-YS-VAR is non-nil iff the style uses the YEAR-SUFFIX
  CSL-variable."
  category info opts bib-opts bib-sort bib-sort-orders
  bib-layout cite-opts cite-sort cite-sort-orders
  cite-layout cite-layout-attrs locale-opts macros terms
  uses-ys-var date-text date-numeric locale)

(defun citeproc-style-parse (style)
  "Return the parsed representation of csl STYLE.
STYLE is either a path to a style file or a style as a string.
Returns a (YEAR-SUFF-P . PARSED-STYLE) cons cell. YEAR-SUFF-P is
non-nil if the style uses the `year-suffix' csl var; PARSED-STYLE
is the parsed form of the xml STYLE-FILE."
  (let ((xml-input (s-matches-p " ?<" style)))
    (with-temp-buffer
      (let ((case-fold-search t))
	(if xml-input (insert style)
	  (insert-file-contents style))
	(goto-char 1)
	(cons (re-search-forward "variable=\"year-suffix\"" nil t)
	      (citeproc-lib-remove-xml-comments
	       (libxml-parse-xml-region (point-min) (point-max))))))))

;; TODO: Parse and store info in a more structured and sensible form. Also,
;; currently the first in-style locale is loaded that is compatible with the
;; locale to be used. In theory, there may be more than one compatible in-style
;; locales that should be merged in an order reflecting their closeness to the
;; requested locale.
(defun citeproc-create-style-from-locale (parsed-style year-suffix locale)
  "Create a citation style from parsed xml style PARSED-STYLE.
YEAR-SUFFIX specifies whether the style explicitly uses the
`year-suffix' csl variable. LOCALE is the locale for which
in-style locale information will be loaded (if available)."
  (let* ((style (citeproc-style--create))
	 (style-opts (cadr parsed-style))
	 locale-loaded)
    (setf (citeproc-style-opts style) style-opts
	  (citeproc-style-uses-ys-var style) year-suffix
	  (citeproc-style-locale style)
	  (or locale (alist-get 'default-locale style-opts)))
    (--each (cddr parsed-style)
      (pcase (car it)
	('info
	 (let* ((info-lst (cddr it))
		(category-info (cl-find-if
				(lambda (x) (and (eq 'category (car x))
						 (eq 'citation-format (caaadr x))))
				info-lst))
		(category (cdaadr category-info)))
	   (setf (citeproc-style-category style) category)))
	('locale
	 (let ((lang (alist-get 'lang (cadr it))))
	   (when (and (citeproc-locale--compatible-p lang locale)
		      (not locale-loaded))
	     (citeproc-style--update-locale style it)
	     (setq locale-loaded t))))
	('citation
	 (citeproc-style--update-cite-info style it))
	('bibliography
	 (citeproc-style--update-bib-info style it))
	('macro
	 (citeproc-style--update-macros style it))))
    style))

(defun citeproc-style--parse-layout-and-sort-frag (frag)
  "Parse a citation or bibliography style xml FRAG.
Return an alist with keys `layout', `opts', `layout-attrs', `sort'
and `sort-orders'."
  (let* ((opts (cadr frag))
	 (sort-p (eq (cl-caaddr frag) 'sort))
	 (layout (citeproc-style--transform-xmltree
		  (elt frag (if sort-p 3 2))))
	 (layout-attrs (cl-cadadr (cl-caddr layout)))
	 sort sort-orders)
    (when sort-p
      (let* ((sort-frag (cl-caddr frag)))
	(setq sort (citeproc-style--transform-xmltree sort-frag)
	      sort-orders (--map (not (string= "descending" (alist-get 'sort (cadr it))))
				 (cddr sort-frag)))))
    `((opts . ,opts) (layout . ,layout) (layout-attrs . ,layout-attrs)
      (sort . ,sort) (sort-orders . ,sort-orders))))

(defun citeproc-style--update-cite-info (style frag)
  "Update the cite info of STYLE on the basis of its parsed FRAG."
  (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
    (setf (citeproc-style-cite-opts style) .opts
	  (citeproc-style-cite-layout style) .layout
	  (citeproc-style-cite-layout-attrs style) .layout-attrs
	  (citeproc-style-cite-sort style) .sort
	  (citeproc-style-cite-sort-orders style) .sort-orders)))

(defun citeproc-style--update-bib-info (style frag)
  "Update the bib info of STYLE on the basis of its parsed FRAG."
  (let-alist (citeproc-style--parse-layout-and-sort-frag frag)
    (setf (citeproc-style-bib-opts style) .opts
	  (citeproc-style-bib-layout style) .layout
	  (citeproc-style-bib-sort style) .sort
	  (citeproc-style-bib-sort-orders style) .sort-orders)))

(defun citeproc-style--update-macros (style frag)
  "Update the macro info of STYLE on the basis of its parsed FRAG."
  (let ((name (cl-cdaadr frag)))
    (setf (car frag) 'macro)
    (setf (cadr frag) nil)
    (push (cons name (citeproc-style--transform-xmltree frag))
	  (citeproc-style-macros style))))

(defun citeproc-style--update-locale (style frag)
  "Update locale info in STYLE using xml fragment FRAG.
FRAG should be a parsed locale element from a style or a locale."
  (--each (cddr frag)
    (pcase (car it)
      ('style-options (setf (citeproc-style-locale-opts style)
			    (-concat (citeproc-style-locale-opts style)
				     (cadr it))))
      ('date
       (citeproc-style--update-locale-date style it))
      ('terms
       (let ((parsed-terms (citeproc-locale-termlist-from-xml-frag (cddr it))))
	 (setf (citeproc-style-terms style)
	       (if (citeproc-style-terms style)
		   (citeproc-term-list-update parsed-terms (citeproc-style-terms style))
		 parsed-terms)))))))

(defun citeproc-style--update-locale-date (style frag)
  "Update date info in STYLE using xml fragment FRAG.
FRAG should be a parsed locale element from a style or a locale."
  (let* ((date-attrs (cadr frag))
	 (form (alist-get 'form date-attrs))
	 (date-format (cons date-attrs
			    (citeproc-lib-named-parts-to-alist frag))))
    (if (string= form "text")
	(unless (citeproc-style-date-text style)
	  (setf (citeproc-style-date-text style) date-format))
      (unless (citeproc-style-date-numeric style)
	(setf (citeproc-style-date-numeric style) date-format)))))

(defconst citeproc-style--opt-defaults
  '((cite-opts near-note-distance "5")
    (locale-opts punctuation-in-quote "false")
    (locale-opts limit-day-ordinals-to-day-1 "false")
    (bib-opts hanging-indent "false")
    (bib-opts line-spacing "1")
    (bib-opts entry-spacing "1")
    (opts initialize-with-hyphen "true")
    (opts demote-non-dropping-particle "display-and-sort"))
  "Global style options.
Specified as a list of (STYLE-SLOT OPTION-NAME OPTION-DEFAULT)
lists.

Note: Collapse-related options are not specified here since their
default settings are interdependent.")

(defun citeproc-style--set-opt (style opt-slot opt value)
  "Set OPT in STYLE's OPT-SLOT to VALUE."
  (setf (cl-struct-slot-value 'citeproc-style opt-slot style)
	(cons (cons opt value)
	      (cl-struct-slot-value 'citeproc-style opt-slot style))))

(defun citeproc-style--set-opt-defaults (style)
  "Set missing options of STYLE to their default values."
  (cl-loop
   for (slot option value) in citeproc-style--opt-defaults do
   (let ((slot-value (cl-struct-slot-value 'citeproc-style slot style)))
     (unless (alist-get option slot-value)
       (setf (cl-struct-slot-value 'citeproc-style slot style)
	     (cons (cons option value) slot-value)))))
  (let* ((cite-opts (citeproc-style-cite-opts style))
	 (collapse (alist-get 'collapse cite-opts)))
    (when (and collapse (not (string= collapse "citation-number")))
      (let ((cite-layout-dl
	     (alist-get 'delimiter (citeproc-style-cite-layout-attrs style)))
	    (cite-group-dl
	     (alist-get 'cite-group-delimiter cite-opts)))
	(unless cite-group-dl
	  (citeproc-style--set-opt style 'cite-opts 'cite-group-delimiter ", "))
	(unless (alist-get 'after-collapse-delimiter cite-opts)
	  (citeproc-style--set-opt
	   style 'cite-opts 'after-collapse-delimiter cite-layout-dl))
	(when (and (member collapse '("year-suffix" "year-suffix-ranged"))
		   (null (alist-get 'year-suffix-delimiter cite-opts)))
	  (citeproc-style--set-opt
	   style 'cite-opts 'year-suffix-delimiter cite-layout-dl))))))

(defun citeproc-style--transform-xmltree (tree)
  "Transform parsed csl xml fragment TREE into a lambda."
  `(lambda (context) ,(citeproc-style--transform-xmltree-1 tree)))

(defun citeproc-style--transform-xmltree-1 (tree)
  "Transform parsed xml fragment TREE into an eval-able form.
Symbols in car position are prefixed with `citeproc--' and the
symbol `context' is inserted everywhere after the second (attrs)
position and before the (possibly empty) body."
  (pcase tree
    ((pred atom) tree)
    (`(names . ,_) (citeproc-style--transform-names tree))
    (_
     `(,(intern (concat "citeproc--" (symbol-name (car tree))))
       ,(list 'quote (cadr tree))
       context
       ,@(mapcar #'citeproc-style--transform-xmltree-1 (cddr tree))))))

(defun citeproc-style--transform-names (frag)
  "Transform the content of a cs:names CSL element xml FRAG."
  (let* ((names-attrs (cadr frag))
	 (body (-remove #'stringp (cddr frag)))
	 (vars (alist-get 'variable names-attrs))
	 substs name-attrs name-parts et-al-attrs
	 is-label label-attrs label-before-names)
    (--each body
      (pcase (car it)
	('name
	 (setq name-attrs (cadr it)
	       name-parts (citeproc-lib-named-parts-to-alist it)
	       label-before-names t))
	('et-al
	 (setq et-al-attrs (cadr it)))
	('label
	 (setq is-label t
	       label-attrs (cadr it)
	       label-before-names nil))
	('substitute
	 (setq substs
	       (mapcar
		(lambda (x)
		  (if (eq (car x) 'names)
		      `(citeproc-name-render-vars
			,(alist-get 'variable (cadr x))
			names-attrs name-attrs name-parts et-al-attrs
			is-label label-before-names label-attrs context)
		    (citeproc-style--transform-xmltree-1 x)))
		(cddr it))))))
    `(if (citeproc-var-value 'suppress-author context) (cons nil 'empty-vars)
       (let* ((names-attrs ',names-attrs)
	      (name-attrs ',name-attrs)
	      (count (string= (alist-get 'form name-attrs) "count"))
	      (et-al-attrs ',et-al-attrs)
	      (name-parts ',name-parts)
	      (label-attrs ',label-attrs)
	      (is-label ,is-label)
	      (label-before-names ,label-before-names)
	      (val (citeproc-name-render-vars
		    ,vars names-attrs name-attrs name-parts et-al-attrs
		    is-label label-before-names label-attrs context))
	      (result (if (car val)
			  val
			(-if-let ((cont . type) (--first (car it)
							 (list ,@substs)))
			    (cons (cons (list '(subst . t)) (list cont)) type)
			  (cons nil 'empty-vars))))
	      (final (if count
			 (let* ((number (citeproc-rt-count-names (car result)))
				(str (if (= 0 number) "" (number-to-string number))))
			   (cons str (cdr result)))
		       result)))
	 ;; Handle `author' citation mode by stopping if needed
	 (citeproc-context-maybe-stop-rendering 'names context final)))))

(defun citeproc-style-cite-note (style)
  "Return whether csl STYLE is a note style."
  (string= (citeproc-style-category style) "note"))

(defun citeproc-style-cite-superscript-p (style)
  "Return whether csl STYLE has a superscript citaton layout."
  (string= (alist-get 'vertical-align (citeproc-style-cite-layout-attrs style))
	   "sup"))

(defun citeproc-style-global-opts (style layout)
  "Return the global opts in STYLE for LAYOUT.
LAYOUT is either `bib' or `cite'."
  (-concat (cl-ecase layout
	     (bib (citeproc-style-bib-opts style))
	     (cite (citeproc-style-cite-opts style)))
	   (citeproc-style-opts style)))

(defun citeproc-style-bib-opts-to-formatting-params (bib-opts)
  "Convert BIB-OPTS to a formatting parameters alist."
  (let ((result
	 (cl-loop
	  for (opt . val) in bib-opts
	  if (memq opt
		   '(hanging-indent line-spacing entry-spacing second-field-align))
	  collect (cons opt
			(pcase val
			  ("true" t)
			  ("false" nil)
			  ("flush" 'flush)
			  ("margin" 'margin)
			  (_ (string-to-number val)))))))
    (if (alist-get 'second-field-align result)
	result
      (cons (cons 'second-field-align nil)
	    result))))

(provide 'citeproc-style)

;;; citeproc-style.el ends here