citeproc-name.el

;;; 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 ((or (null g-uninited)
			  (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)))

(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."
  (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