;;; parse-date.el --- parsing time/date strings -*- lexical-binding: t -*-

;; Copyright (C) 2021 Free Software Foundation, Inc.

;; Author: Bob Rogers <rogers@rgrjr.com>
;; Keywords: util

;; 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:

;; 'parse-date' parses a time and/or date in a string and returns a
;; list of values, just like `decode-time', where unspecified elements
;; in the string are returned as nil (except unspecified DST is
;; returned as -1).  `encode-time' may be applied on these values to
;; obtain an internal time value.  If left to its own devices, it
;; accepts a wide variety of formats, but can be told to insist on a
;; particular date/time format.

;; Historically, `parse-time-string' was used for this purpose, but it
;; was focused on email date formats, and gradually but imperfectly
;; extended to handle other formats.  'parse-date' is compatible in
;; that it parses the same input formats and uses the same return
;; value format, but is stricter in that it signals an error for
;; tokens that `parse-time-string' would simply ignore.

;;; TODO:
;;
;; * Add a euro-date format for DD/MM/YYYY ?
;;

;;; Code:

(require 'cl-lib)
(require 'iso8601)
(require 'parse-time)

(define-error 'date-parse-error "Date/time parse error" 'error)

(defconst parse-date--ends-with-alpha-tz-re
  (concat " \\(" (mapconcat #'car parse-time-zoneinfo "\\|") "\\)$")
  "Recognize an alphanumeric timezone at the end of the string.")

(defun parse-date--guess-rfc822-formats (date-string)
  (let ((case-fold-search t))
    (cond ((string-match "(" date-string) 'rfc2822)
          ((string-match parse-date--ends-with-alpha-tz-re date-string)
            ;; Alphabetic timezones are legacy syntax.
            'rfc822)
          ((string-match " [-+][0-9][0-9][0-9][0-9][ \t\n]*\\($\\}(\\)"
                         date-string)
            ;; Note that an ISO-8601 timezone has a colon in the middle
            ;; and no preceding space.
            'rfc2822)
          (t nil))))

(defun parse-date--guess-format (date-string)
  (cond ((iso8601-valid-p date-string) 'iso-8601)
        ((parse-date--guess-rfc822-formats date-string))
        (t nil)))

(defun parse-date--ignore-char? (char)
  ;; Ignore whitespace and commas.
  (or (eq char ?\ ) (eq char ?\t) (eq char ?\r) (eq char ?\n) (eq char ?,)))

(defun parse-date--tokenize-string (string &optional strip-fws?)
  "Turn STRING into tokens, separated only by whitespace and commas.
Multiple commas are ignored.  Pure digit sequences are turned
into integers.  If STRIP-FWS? is true, then folding whitespace as
defined by RFC2822 (strictly, the CFWS production that also
accepts comments) is stripped out by treating it like whitespace;
if it's value is the symbol `first', we exit when we see the
first '(' (per RFC2822), else we strip them all (per RFC822)."
  (let ((index 0)
	(end (length string))
        (fws-eof? (eq strip-fws? 'first))
	(list ()))
    (when fws-eof?
      ;; In order to stop on the first "(", we need to see it as
      ;; non-whitespace.
      (setq strip-fws? nil))
    (cl-flet ((skip-ignored ()
                ;; Skip ignored characters at index (the scan
                ;; position).  Skip RFC822 comments in matched parens
                ;; if strip-fws? is true, but do not complain about
                ;; unterminated comments.
                (let ((char nil)
                      (nest 0))
                  (while (and (< index end)
                              (setq char (aref string index))
                              (or (> nest 0)
                                  (parse-date--ignore-char? char)
                                  (and strip-fws? (eql char ?\())))
                    (cl-incf index)
                    ;; FWS bookkeeping.
                    (cond ((not strip-fws?))
                          ((and (eq char ?\\)
                                (< (1+ index) end))
	                    ;; Move to the next char but don't check
	                    ;; it to see if it might be a paren.
                            (cl-incf index))
                          ((eq char ?\() (cl-incf nest))
                          ((eq char ?\)) (cl-decf nest)))))))
      (skip-ignored)		;; Skip leading whitespace.
      (while (and (< index end)
                  (not (and fws-eof?
                            (eq (aref string index) ?\())))
        (let* ((start index)
               (char (aref string index))
               (all-digits (<= ?0 char ?9)))
          ;; char is valid; look for more valid characters.
          (when (and strip-fws?
                     (eq char ?\\)
                     (< (1+ index) end))
            ;; Escaped character, which might be a "(".  If so, we are
            ;; correct to include it in the token, even though the
            ;; caller is sure to barf.  If not, we violate RFC2?822 by
            ;; not removing the backslash, but no characters in valid
            ;; RFC2?822 dates need escaping anyway, so it shouldn't
            ;; matter that this is not done strictly correctly.  --
            ;; rgr, 24-Dec-21.
            (cl-incf index))
          (while (and (< (cl-incf index) end)
                      (setq char (aref string index))
                      (not (or (parse-date--ignore-char? char)
                               (and strip-fws?
                                    (eq char ?\()))))
            (unless (<= ?0 char ?9)
              (setq all-digits nil))
            (when (and strip-fws?
                       (eq char ?\\)
                       (< (1+ index) end))
              ;; Escaped character, see above.
              (cl-incf index)))
          (push (if all-digits
                    (cl-parse-integer string :start start :end index)
                  (substring string start index))
                list)
          (skip-ignored)))
      (nreverse list))))

(defconst parse-date--slot-names
  '(second minute hour day month year weekday dst zone)
  "Names of return value slots, for better error messages
See the decoded-time defstruct.")

(defconst parse-date--slot-ranges
  '((0 60) (0 59) (0 23) (1 31) (1 12) (1 9999))
  "Numeric slot ranges, for bounds checking.
Note that RFC2822 explicitly requires that seconds go up to 60,
to allow for leap seconds (see Mills, D., 'Network Time
Protocol', STD 12, RFC 1119, September 1989).")

(defun parse-date--x822 (time-string obs-format?)
  ;; Parse an RFC2822 or (if obs-format? is true) RFC822 date.  The
  ;; strict syntax for the former is as follows:
  ;;
  ;;	[ day-of-week "," ] day FWS month-name FWS year FWS time [CFWS]
  ;;
  ;; where "time" is:
  ;;
  ;;	2DIGIT ":" 2DIGIT [ ":" 2DIGIT ] FWS ( "+" / "-" ) 4DIGIT
  ;;
  ;; RFC822 also accepts comments in random places (which is handled
  ;; by parse-date--tokenize-string) and two-digit years.  We are
  ;; somewhat more lax in what we accept (specifically, the hours
  ;; don't have to be two digits, and the TZ and the comma after the
  ;; DOW are optional), but we do insist that the items that are
  ;; present do appear in this order.
  (let ((tokens (parse-date--tokenize-string (downcase time-string)
                                            (if obs-format? 'all 'first)))
        (time (list nil nil nil nil nil nil nil -1 nil)))
    (cl-labels ((set-matched-slot (slot index token)
                  ;; Assign a slot value from match data if index is
                  ;; non-nil, else from token, signalling an error if
                  ;; it's already been assigned or is out of range.
                  (let ((value (if index
                                   (cl-parse-integer (match-string index token))
                                 token))
                        (range (nth slot parse-date--slot-ranges)))
                    (unless (equal (nth slot time)
                                   (if (= slot 7) -1 nil))
                      (signal 'date-parse-error
                              (list "Duplicate slot value"
                                    (nth slot parse-date--slot-names) token)))
                    (when (and range
                               (not (<= (car range) value (cadr range))))
                      (signal 'date-parse-error
                              (list "Slot out of range"
                                    (nth slot parse-date--slot-names)
                                    token (car range) (cadr range))))
                    (setf (nth slot time) value)))
                (set-numeric (slot token)
                  (unless (natnump token)
                    (signal 'date-parse-error
                              (list "Not a number"
                                    (nth slot parse-date--slot-names) token)))
                  (set-matched-slot slot nil token)))
      ;; Check for weekday.
      (let ((dow (assoc (car tokens) parse-time-weekdays)))
        (when dow
          ;; Day of the week.
          (set-matched-slot 6 nil (cdr dow))
          (pop tokens)))
      ;; Day.
      (set-numeric 3 (pop tokens))
      ;; Alphabetic month.
      (let* ((month (pop tokens))
             (match (assoc month parse-time-months)))
        (if match
            (set-matched-slot 4 nil (cdr match))
          (signal 'date-parse-error
                  (list "Expected an alphabetic month" month))))
      ;; Year.
      (let ((year (pop tokens)))
        ;; Check the year for the right number of digits.
        (cond ((> year 1000)
                (set-numeric 5 year))
              ((or (not obs-format?)
                   (>= year 100))
                "Four digit years are required but found '%s'" year)
              ((>= year 50)
                ;; second half of the 20th century.
                (set-numeric 5 (+ 1900 year)))
              (t
                ;; first half of the 21st century.
                (set-numeric 5 (+ 2000 year)))))
      ;; Time.
      (let ((time (pop tokens)))
        (cond ((or (null time) (natnump time))
                (signal 'date-parse-error
                        (list "Expected a time" time)))
              ((string-match
                "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$"
                time)
                (set-matched-slot 2 1 time)
                (set-matched-slot 1 2 time)
                (set-matched-slot 0 3 time))
              ((string-match "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\)$" time)
                ;; Time without seconds.
                (set-matched-slot 2 1 time)
                (set-matched-slot 1 2 time)
                (set-matched-slot 0 nil 0))
              (t
                (signal 'date-parse-error
                        (list "Expected a time" time)))))
      ;; Timezone.
      (let* ((zone (pop tokens))
             (match (assoc zone parse-time-zoneinfo)))
        (cond (match
                (set-matched-slot 8 nil (cadr match))
                (set-matched-slot 7 nil (caddr match)))
              ((and (stringp zone)
                    (string-match "^[-+][0-9][0-9][0-9][0-9]$" zone))
                ;; Numeric time zone.
                (set-matched-slot
                  8 nil
                  (* 60
                     (+ (cl-parse-integer zone :start 3 :end 5)
                        (* 60 (cl-parse-integer zone :start 1 :end 3)))
                     (if (= (aref zone 0) ?-) -1 1))))
              (zone
                (signal 'date-parse-error
                        (list "Expected a timezone" zone)))))
      (when tokens
        (signal 'date-parse-error
                (list "Extra token(s)" (car tokens)))))
    time))

(defun parse-date--default (time-string two-digit-year?)
  ;; Do the standard parsing thing.  This is mostly free form, in that
  ;; tokens may appear in any order, but we expect to introduce some
  ;; state dependence.
  (let ((tokens (parse-date--tokenize-string (downcase time-string)))
        (time (list nil nil nil nil nil nil nil -1 nil)))
    (cl-flet ((set-matched-slot (slot index token)
                ;; Assign a slot value from match data if index is
                ;; non-nil, else from token, signalling an error if
                ;; it's already been assigned or is out of range.
                (let ((value (if index
                                 (cl-parse-integer (match-string index token))
                               token))
                      (range (nth slot parse-date--slot-ranges)))
                  (unless (equal (nth slot time)
                                 (if (= slot 7) -1 nil))
                    (signal 'date-parse-error
                              (list "Duplicate slot value"
                                    (nth slot parse-date--slot-names) token)))
                  (when (and range
                             (not (<= (car range) value (cadr range))))
                    (signal 'date-parse-error
                            (list "Slot out of range"
                                         (nth slot parse-date--slot-names)
                                         token (car range) (cadr range))))
                  (setf (nth slot time) value))))
      (while tokens
        (let ((token (pop tokens))
              (match nil))
          (cond ((numberp token)
                  ;; A bare number could be a month, day, or year.
                  ;; The order of these tests matters greatly.
                  (cond ((>= token 1000)
                          (set-matched-slot 5 nil token))
                        ((and (<= 1 token 31)
                              (not (nth 3 time)))
                          ;; Assume days come before months or years.
                          (set-matched-slot 3 nil token))
                        ((and (<= 1 token 12)
                              (not (nth 4 time)))
                          ;; Assume days come before years.
                          (set-matched-slot 4 nil token))
                        ((or (nth 5 time)
                             (not two-digit-year?)
                             (> token 100))
                          (signal 'date-parse-error
                                  (list "Unrecognized token" token)))
                        ;; It's a two-digit year.
                        ((>= token 50)
                          ;; second half of the 20th century.
                          (set-matched-slot 5 nil (+ 1900 token)))
                        (t
                          ;; first half of the 21st century.
                          (set-matched-slot 5 nil (+ 2000 token)))))
                ((setq match (assoc token parse-time-weekdays))
                  (set-matched-slot 6 nil (cdr match)))
                ((setq match (assoc token parse-time-months))
                  (set-matched-slot 4 nil (cdr match)))
                ((setq match (assoc token parse-time-zoneinfo))
                  (set-matched-slot 8 nil (cadr match))
                  (set-matched-slot 7 nil (caddr match)))
                ((string-match "^[-+][0-9][0-9][0-9][0-9]$" token)
                  ;; Numeric time zone.
                  (set-matched-slot
                    8 nil
                    (* 60
                       (+ (cl-parse-integer token :start 3 :end 5)
                          (* 60 (cl-parse-integer token :start 1 :end 3)))
                       (if (= (aref token 0) ?-) -1 1))))
                ((string-match
                  "^\\([0-9][0-9][0-9][0-9]\\)[-/]\\([0-9][0-9]?\\)[-/]\\([0-9][0-9]?\\)$"
                  token)
                  ;; ISO-8601-style date (YYYY-MM-DD).
                  (set-matched-slot 5 1 token)
                  (set-matched-slot 4 2 token)
                  (set-matched-slot 3 3 token))
                ((string-match
                  "^\\([0-9][0-9]?\\)[-/]\\([0-9][0-9]?\\)[-/]\\([0-9][0-9][0-9][0-9]\\)$"
                  token)
                  ;; US date (MM-DD-YYYY), but we insist on four
                  ;; digits for the year.
                  (set-matched-slot 4 1 token)
                  (set-matched-slot 3 2 token)
                  (set-matched-slot 5 3 token))
                ((string-match
                  "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$"
                  token)
                  (set-matched-slot 2 1 token)
                  (set-matched-slot 1 2 token)
                  (set-matched-slot 0 3 token))
                ((string-match "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\)$" token)
                  ;; Time without seconds.
                  (set-matched-slot 2 1 token)
                  (set-matched-slot 1 2 token)
                  (set-matched-slot 0 nil 0))
                ((member token '("am" "pm"))
                  (unless (nth 2 time)
                    (signal 'date-parse-error
                            (list "Missing time" token)))
                  (unless (<= (nth 2 time) 12)
                    (signal 'date-parse-error
                            (list "Time already past noon" token)))
                  (when (equal token "pm")
                    (cl-incf (nth 2 time) 12)))
                (t
                  (signal 'date-parse-error
                          (list "Unrecognized token" token)))))))
    time))

;;;###autoload
(cl-defgeneric parse-date (time-string &optional format)
  "Parse TIME-STRING according to FORMAT, returning a list.
The FORMAT value is a symbol that may be one of the following:

   iso-8601 => parse the string according to the ISO-8601
standard.  See `parse-iso8601-time-string'.

   rfc822 => parse an RFC822 (old email) date, which allows
two-digit years and internal '()' comments.  In dates of the form
'11 Jan 12', the 11 is assumed to be the day, and the 12 is
assumed to mean 2012.  Be sure you really want this; the format
is more limited than most human-supplied dates.

   rfc2822 => parse an RFC2822 (new email) date, which allows
only four-digit years.  Again, this is a fairly restricted
format, with fields required to be in a specified order and
representation.

   us-date => parse a US-style date, of the form MM/DD/YYYY, but
allowing two-digit years.  In dates of the form '01/11/12', the 1
is the month, 11 is the day, and the 12 is assumed to mean 2012.

   nil => like us-date with two-digit years disallowed.

Anything else is treated as iso-8601 if it looks similar, else
us-date with two-digit years disallowed.

   * For all formats except iso-8601, parsing is case-insensitive.

   * Commas and whitespace are ignored.

   * In date specifications, either '/' or '-' may be used to
separate components, but all three components must be given.

   * A date that starts with four digits is YYYY-MM-DD, ISO-8601
style, but a date that ends with four digits is MM-DD-YYYY [at
least in us-date format].

   * Two digit years, when allowed, are in the 1900's when
between 50 and 99 inclusive and in the 2000's when between 0 and
49 inclusive.

A `date-parse-error' is signalled when time values are duplicated,
unrecognized, or out of range.  No consistency checks between
fields are done.  For instance, the weekday is not checked to see
that it corresponds to the date, and parse-date complains about
the 32nd of March (or any other month) but blithely accepts the
29th of February in non-leap years -- or the 31st of February in
any year.

The result is a list of (SEC MIN HOUR DAY MON YEAR DOW DST TZ),
which can be accessed as a decoded-time defstruct (q.v.),
e.g. `decoded-time-year' to extract the year, and turned into an
Emacs timestamp by `encode-time'.  The values returned are
identical to those of `decode-time', but any unknown values other
than DST are returned as nil, and an unknown DST value is
returned as -1.")

(cl-defmethod parse-date (time-string (_format (eql iso-8601)))
  (iso8601-parse time-string))

(cl-defmethod parse-date (time-string (_format (eql rfc2822)))
  (parse-date--x822 time-string nil))

(cl-defmethod parse-date (time-string (_format (eql rfc822)))
  (parse-date--x822 time-string t))

(cl-defmethod parse-date (time-string (_format (eql us-date)))
  (parse-date--default time-string t))

(cl-defmethod parse-date (time-string (_format (eql nil)))
  (parse-date--default time-string nil))

(cl-defmethod parse-date (time-string _format)
  ;; Re-dispatch after guessing the format.
  (parse-date time-string (parse-date--guess-format time-string)))

(provide 'parse-date)

;;; parse-date.el ends here