282 lines
10 KiB
EmacsLisp
282 lines
10 KiB
EmacsLisp
;;; citeproc-date.el --- CSL date rendering -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2017 András Simonyi
|
||
|
||
;; Author: András Simonyi <andras.simonyi@gmail.com>
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;; This file is not part of GNU Emacs.
|
||
|
||
;;; Commentary:
|
||
|
||
;; Structure type and functions to render CSL date elements.
|
||
|
||
;;; Code:
|
||
|
||
(require 'subr-x)
|
||
(require 'cl-lib)
|
||
(require 'dash)
|
||
(require 'let-alist)
|
||
(require 's)
|
||
|
||
(require 'citeproc-lib)
|
||
(require 'citeproc-rt)
|
||
(require 'citeproc-context)
|
||
(require 'citeproc-number)
|
||
|
||
(cl-defstruct (citeproc-date (:constructor citeproc-date-create))
|
||
"Struct for representing dates.
|
||
Slots YEAR, MONTH, DAY are integers, while SEASON and CIRCA are
|
||
booleans. SEASON indicates whether the integer in slot MONTH is
|
||
to be interpreted as a season number."
|
||
(year nil) (month nil) (day nil) (season nil) (circa nil))
|
||
|
||
(defun citeproc-date-parse (date-rep)
|
||
"Parse CSL json date repr. DATE-REP into an internal one."
|
||
(let-alist date-rep
|
||
(--map (citeproc-date--conv it .season .circa) .date-parts)))
|
||
|
||
(defun citeproc-date--conv (dates &optional season circa)
|
||
"Convert date-part list DATES to a citeproc-date struct.
|
||
Set the remaining slots to the values SEASON and CIRCA."
|
||
(-let* ((numeric
|
||
(--map (if (stringp it) (string-to-number it) it) dates))
|
||
((year month day) numeric))
|
||
(citeproc-date-create :year year :month month :day day
|
||
:season season :circa circa)))
|
||
|
||
(defun citeproc-date--partattrs-for-sort (part-attrs)
|
||
"Return a sort-key version of PART-ATTRS."
|
||
(let (result)
|
||
(when (assoc 'day part-attrs)
|
||
(push '(day . ((form . "numeric-leading-zeros"))) result))
|
||
(when (assoc 'month part-attrs)
|
||
(push '(month . ((form . "numeric-leading-zeros"))) result))
|
||
(when (assoc 'year part-attrs)
|
||
(push '(year . ((form . "long"))) result))
|
||
result))
|
||
|
||
(defun citeproc--date (attrs context &rest body)
|
||
"Function corresponding to the date CSL element."
|
||
(-let* (((&alist 'variable var
|
||
'form form)
|
||
attrs)
|
||
(var-sym (intern var))
|
||
(parsed-dates (citeproc-var-value var-sym context))
|
||
((d1 d2) parsed-dates)
|
||
(result
|
||
(if d1
|
||
(progn
|
||
(when form
|
||
(let ((localized (citeproc-date--localized-attrs attrs body context)))
|
||
(setq attrs (car localized)
|
||
body (cdr localized))))
|
||
(when (eq (citeproc-context-render-mode context) 'sort)
|
||
(setq body (citeproc-date--partattrs-for-sort body)))
|
||
(if (citeproc-date--renders-with-attrs-p d1 body)
|
||
(progn
|
||
(push `(rendered-var . ,(intern var)) attrs)
|
||
(cons (if d2
|
||
(citeproc-date--render-range d1 d2 attrs body context)
|
||
(citeproc-date--render d1 attrs body context))
|
||
'present-var))
|
||
(cons nil 'empty-vars)))
|
||
(cons nil 'empty-vars))))
|
||
;; Handle `year' citation mode by stopping if needed
|
||
(citeproc-context-maybe-stop-rendering 'issued context result var-sym)))
|
||
|
||
(defun citeproc--date-part (attrs _context &rest _body)
|
||
"Function corresponding to the date-part CSL element."
|
||
(cons (intern (alist-get 'name attrs))
|
||
attrs))
|
||
|
||
(defun citeproc-date--renders-with-attrs-p (date part-attrs)
|
||
"Whether DATE contains date-parts corresponding to PART-ATTRS."
|
||
(let ((date-parts (mapcar #'car part-attrs)))
|
||
(or (memq 'year date-parts) ; All dates contain a year
|
||
(and (memq 'month date-parts) (citeproc-date-month date))
|
||
(and (memq 'day date-parts) (citeproc-date-day date)))))
|
||
|
||
(defun citeproc-date--localized-attrs (attrs part-attrs context)
|
||
"Return the localized date attrs merged with date ATTRS and date PART-ATTRS."
|
||
(-let* (((&alist 'form form
|
||
'date-parts date-parts)
|
||
attrs)
|
||
((loc-attrs . loc-part-attrs)
|
||
(if (string= form "text") (citeproc-context-date-text context)
|
||
(citeproc-context-date-numeric context))))
|
||
(pcase (citeproc-lib-intern date-parts)
|
||
('year
|
||
(setq loc-part-attrs
|
||
(--select (eq (car it) 'year) loc-part-attrs)))
|
||
('year-month
|
||
(setq loc-part-attrs
|
||
(--select (memq (car it) '(year month)) loc-part-attrs))))
|
||
(cons (-concat attrs loc-attrs)
|
||
(--map (cons (car it)
|
||
(-concat (alist-get (car it) part-attrs) (cdr it)))
|
||
loc-part-attrs))))
|
||
|
||
(defun citeproc-date--render (d attrs part-attrs context)
|
||
"Render citeproc-date D according to formatting in ATTRS and PART-ATTRS.
|
||
Return a rich-text content."
|
||
(if (citeproc-var-value 'suppress-date context)
|
||
(citeproc-rt-format-single attrs "<suppressed-date>" context)
|
||
(let ((rendered-date (citeproc-date--render-parts d part-attrs context)))
|
||
(citeproc-rt-join-formatted attrs rendered-date context))))
|
||
|
||
(defun citeproc-date--render-parts (d part-attrs context &optional no-last-suffix)
|
||
"Render the parts of citeproc-date D according to PART-ATTRS.
|
||
Return a list of rich-text contents. If optional NO-LAST-SUFFIX
|
||
is non-nil then remove the suffix attribute of the last rendered
|
||
element (used for date range rendering)."
|
||
(let ((result (--map (pcase (car it)
|
||
('year (citeproc-date--render-year d (cdr it) context))
|
||
('month (citeproc-date--render-month d (cdr it) context))
|
||
('day (citeproc-date--render-day d (cdr it) context)))
|
||
part-attrs)))
|
||
(-if-let* ((n-l-s no-last-suffix)
|
||
(last (car (last result)))
|
||
(wo-suffix (and (consp last)
|
||
(cons (--remove (eq 'suffix (car it)) (car last))
|
||
(cdr last)))))
|
||
(-snoc (butlast result) wo-suffix)
|
||
result)))
|
||
|
||
(defun citeproc-date--render-range-parts (d1 d2 part-attrs sep context)
|
||
"Render the parts of citeproc-dates D1 and D2 according to PART-ATTRS.
|
||
PART-ATTRS is a list containing either part-attrs or lists of part-attrs.
|
||
The formers are only rendered for D1, while the latters are rendered for both
|
||
D1 and D2. Return a list of rich-text contents."
|
||
(--mapcat (pcase (car it)
|
||
('year (list (citeproc-date--render-year d1 (cdr it) context)))
|
||
('month (list (citeproc-date--render-month d1 (cdr it) context)))
|
||
('day (list (citeproc-date--render-day d1 (cdr it) context)))
|
||
(_ (-concat (citeproc-date--render-parts d1 it context t)
|
||
(list sep)
|
||
(citeproc-date--render-parts d2 it context))))
|
||
part-attrs))
|
||
|
||
(defun citeproc-date--render-range (d1 d2 attrs part-attrs context)
|
||
"Render the range given by dates D1 D2 according to attrs."
|
||
(if (citeproc-var-value 'suppress-date context)
|
||
(citeproc-rt-format-single attrs "" context)
|
||
(let* ((gran (min (citeproc-date--gran d1)
|
||
(citeproc-date--attrs-gran part-attrs)))
|
||
(range-sep (or (alist-get 'range-delimiter
|
||
(alist-get (elt '(year month day) gran)
|
||
part-attrs))
|
||
"–"))
|
||
(range-p-attrs
|
||
(cond ((/= (citeproc-date-year d1) (citeproc-date-year d2))
|
||
(list part-attrs))
|
||
((/= (citeproc-date-month d1) (citeproc-date-month d2))
|
||
(let ((year-part (--find (eq 'year (car it))
|
||
part-attrs))
|
||
(attrs-wo-year
|
||
(--remove (eq 'year (car it))
|
||
part-attrs)))
|
||
(cond ((eq (caar part-attrs) 'year)
|
||
(list year-part attrs-wo-year))
|
||
((eq (caar (last part-attrs)) 'year)
|
||
(list attrs-wo-year year-part))
|
||
(t (list attrs-wo-year)))))
|
||
(t (--map (if (eq (car it) 'day) (list it) it)
|
||
part-attrs))))
|
||
(rendered-range (citeproc-date--render-range-parts d1 d2 range-p-attrs range-sep
|
||
context)))
|
||
(citeproc-rt-join-formatted attrs rendered-range context))))
|
||
|
||
(defun citeproc-date--attrs-gran (d-attrs)
|
||
"Return the granularity (smallest unit) of date-attrs alist D-ATTRS.
|
||
The returned value is 0, 1 or 2, corresponding to a year, month
|
||
or day granularity."
|
||
(cond ((assoc 'day d-attrs) 2)
|
||
((assoc 'month d-attrs) 1)
|
||
(t 0)))
|
||
|
||
(defun citeproc-date--gran (date)
|
||
"Return the granularity (smallest unit) in citeproc-date struct DATE.
|
||
The returned value is 0, 1 or 2, corresponding to a year, month
|
||
or day granularity."
|
||
(cond ((citeproc-date-day date) 2)
|
||
((citeproc-date-month date) 1)
|
||
(t 0)))
|
||
|
||
(defun citeproc-date--render-year (d attrs context)
|
||
"Render the year in date D according to formatting in ATTRS.
|
||
D is a citeproc-date structure. Return a rich-text content."
|
||
(-let* ((form (alist-get 'form attrs))
|
||
(year (citeproc-date-year d))
|
||
(s (number-to-string (abs year)))
|
||
(era
|
||
(cond ((> year 999) "")
|
||
((> year 0) (citeproc-term-get-text "ad" context))
|
||
(t (citeproc-term-get-text "bc" context)))))
|
||
|
||
(citeproc-rt-format-single attrs (concat (if (string= form "short")
|
||
(s-right 2 s)
|
||
s)
|
||
era)
|
||
context)))
|
||
|
||
(defun citeproc-date--render-month (d attrs context)
|
||
"Render the month in date D according to formatting in ATTRS.
|
||
D is a citeproc-date structure. Return a rich-text content."
|
||
(-if-let (month (citeproc-date-month d))
|
||
(let ((form (alist-get 'form attrs))
|
||
(term-pref (if (citeproc-date-season d)
|
||
"season-" "month-")))
|
||
(citeproc-rt-format-single
|
||
attrs
|
||
(pcase (citeproc-lib-intern form)
|
||
('numeric (number-to-string month))
|
||
('numeric-leading-zeros (format "%02d" month))
|
||
('short (citeproc-term-inflected-text
|
||
(concat term-pref (format "%02d" month))
|
||
'short nil context))
|
||
(_ (citeproc-term-inflected-text
|
||
(concat term-pref (format "%02d" month))
|
||
'long nil context)))
|
||
context))
|
||
nil))
|
||
|
||
(defun citeproc-date--render-day (d attrs context)
|
||
"Render the day in date D according to formatting in ATTRS.
|
||
D is a citeproc-date structure. Return a rich-text content."
|
||
(-if-let (day (citeproc-date-day d))
|
||
(let ((form (alist-get 'form attrs))
|
||
(month (citeproc-date-month d)))
|
||
(citeproc-rt-format-single
|
||
attrs
|
||
(cond
|
||
((string= form "numeric-leading-zeros")
|
||
(format "%02d" day))
|
||
((and (string= form "ordinal")
|
||
(or (= day 1)
|
||
(not (string= "true"
|
||
(alist-get 'limit-day-ordinals-to-day-1
|
||
(citeproc-context-locale-opts context))))))
|
||
(citeproc-number--format-as-ordinal (number-to-string day)
|
||
(concat "month-" (format "%02d" month))
|
||
context))
|
||
(t (number-to-string day)))
|
||
context))
|
||
nil))
|
||
|
||
(provide 'citeproc-date)
|
||
|
||
;;; citeproc-date.el ends here
|