265 lines
11 KiB
Common Lisp
265 lines
11 KiB
Common Lisp
(defpackage clash/parse-date
|
|
(:documentation "Functions for parsing dates and date ranges.")
|
|
(:use #:cl)
|
|
(:export #:print-date-parsing-help
|
|
#:date-parse-error
|
|
#:date-parse-error-source
|
|
#:date-parse-error-position
|
|
#:dase-parse-error-message
|
|
#:parse-date-time
|
|
#:parse-date-range
|
|
#:timestamp-in-ranges
|
|
#:option-date-range
|
|
#:option-date-range-ranges))
|
|
|
|
(in-package :clash/parse-date)
|
|
|
|
(defun print-date-parsing-help (stream)
|
|
"Print information about date parsing to STREAM."
|
|
(format stream "~
|
|
Dates can take one of the following forms (<THING> means THING is required,
|
|
[THING] means it is optional):
|
|
\"now\" - the current date and time
|
|
\"today\"* - midnight on the current day
|
|
\"yesterday\"* - midnight on the day before the current day
|
|
\"<NUMBER>\" - integer seconds since midnight on January 1 1970 (UCT)
|
|
\"<M> <D> [Y]\"* - midnight on the Dth day of M (a month's name) of the Yth
|
|
year, or the current year if Y is omitted (any of the
|
|
whitespace between M, D, and Y can be replaced with a \"/\")
|
|
In the above table, any format which has a * next to it can optionally be
|
|
followed by a time in the format:
|
|
\"<HOUR>:<MINUTE>[:SECOND] [AM|PM]\"
|
|
If SECOND is omitted, it is 0. If AM or PM are omitted, the time is assumed to
|
|
be in 24-format. If the time is omitted entirely, midnight on the given date is
|
|
assumed.
|
|
|
|
Date ranges consist of one or two dates, separated by \"..\". If just one date
|
|
is given without a separator, the pattern matches exactly that date (and
|
|
time). If two dates are given, the patten matches any time between the two dates
|
|
(inclusive of the bounds). If just a date of the form \"<START>..\" is given, it
|
|
means \"any time after START\". Likewise, any date of the form \"..<END>\" means
|
|
\"anytime before END\".
|
|
|
|
Dates are supplied to commands that support then via the -R or --date-range
|
|
flags. These flags can be given any number of times. Any item which matches at
|
|
least one range given will match (that is, the union of all given dates).~%"))
|
|
|
|
(define-condition date-parse-error (error)
|
|
((source :accessor date-parse-error-source
|
|
:type string
|
|
:initarg :source
|
|
:documentation "The string that failed to parse.")
|
|
(pos :accessor date-parse-error-position
|
|
:type (or null integer)
|
|
:initarg :position
|
|
:initform nil
|
|
:documentation "The position of the error, or nil.")
|
|
(message :accessor date-parse-error-message
|
|
:type string
|
|
:initarg :message
|
|
:documentation "A message describing the error."))
|
|
(:report (lambda (condition stream)
|
|
(format
|
|
stream "Failed to parse date ~S~@[ at position ~A~]: ~A"
|
|
(date-parse-error-source condition)
|
|
(date-parse-error-position condition)
|
|
(date-parse-error-message condition))))
|
|
(:documentation "A condition representing a failure in parsing a date range."))
|
|
|
|
(defparameter *month-conversion-table*
|
|
'((1 "january" "jan")
|
|
(2 "february" "feb")
|
|
(3 "march" "mar")
|
|
(4 "april" "apr")
|
|
(5 "may")
|
|
(6 "june" "jun")
|
|
(7 "july" "jly" "jul")
|
|
(8 "august" "aug")
|
|
(9 "september" "sep")
|
|
(10 "october" "oct")
|
|
(11 "november" "nov")
|
|
(12 "december" "dec")))
|
|
|
|
(defun parse-month-string (str)
|
|
(loop for (num . text) in *month-conversion-table*
|
|
when (member str text :test 'equalp)
|
|
do (return num)))
|
|
|
|
(defun add-time-registers (source stamp registers)
|
|
(destructuring-bind (hour minute second am-pm) (last registers 4)
|
|
(local-time:adjust-timestamp stamp
|
|
(offset :sec (parse-integer (or second "0")))
|
|
(offset :minute (parse-integer (or minute "0")))
|
|
(offset :hour
|
|
(if (not hour)
|
|
0
|
|
(cond
|
|
((or (not am-pm) (equalp am-pm "am")) (parse-integer hour))
|
|
((equalp am-pm "pm") (+ (parse-integer hour) 12))
|
|
(t (error 'date-parse-error
|
|
:source source
|
|
:message
|
|
(format nil "excpected \"AM\"/\"PM\", got: ~A"
|
|
am-pm)))))))))
|
|
|
|
(defun current-year ()
|
|
"Return the current year."
|
|
(local-time:timestamp-year (local-time:now)))
|
|
|
|
(defun local-today ()
|
|
"Return a timestamp representing the midnight today in local-time."
|
|
(local-time:adjust-timestamp! (local-time:now)
|
|
(set :hour 0)
|
|
(set :minute 0)
|
|
(set :sec 0)
|
|
(set :nsec 0)))
|
|
|
|
(defparameter *date-parse-formats*
|
|
(let ((time-regexp
|
|
(format nil "(?:\\s|$)(?:\\s*([0-9]{1,2}):([0-9]{1,2})~
|
|
(?::([0-9]{1,2}))?(?:\\s*(AM|PM))?)?"))
|
|
out)
|
|
(flet ((def (regexp func)
|
|
(push (cons (cl-ppcre:create-scanner
|
|
(format nil "~A~A" regexp time-regexp)
|
|
:extended-mode t :case-insensitive-mode t
|
|
:multi-line-mode t)
|
|
func)
|
|
out))
|
|
(def-no-time (regexp func)
|
|
(push (cons (cl-ppcre:create-scanner regexp
|
|
:extended-mode t :case-insensitive-mode t
|
|
:multi-line-mode t)
|
|
func)
|
|
out)))
|
|
(def-no-time "^$"
|
|
(lambda (source registers)
|
|
(declare (ignore source registers))
|
|
(local-time:now)))
|
|
(def-no-time "[0-9]+"
|
|
(lambda (source registers)
|
|
(declare (ignore registers))
|
|
(local-time:unix-to-timestamp (parse-integer source))))
|
|
(def-no-time "now"
|
|
(lambda (source registers)
|
|
(declare (ignore source registers))
|
|
(local-time:now)))
|
|
(def "today"
|
|
(lambda (source registers)
|
|
(add-time-registers source
|
|
(local-today)
|
|
registers)))
|
|
(def "yesterday"
|
|
(lambda (source registers)
|
|
(add-time-registers source
|
|
(local-time:adjust-timestamp! (local-today)
|
|
(offset :day -1))
|
|
registers)))
|
|
;; 2025/10/23 3:00 pm
|
|
(def "([0-9]+)(?:\\s+|/)([0-9]{1,2})(?:\\s+|/)([0-9]{1,2})"
|
|
(lambda (source registers)
|
|
(destructuring-bind (year month day &rest ignore) registers
|
|
(declare (ignore ignore))
|
|
(add-time-registers source
|
|
(local-time:encode-timestamp
|
|
0 0 0 0
|
|
(parse-integer day)
|
|
(parse-integer month)
|
|
(parse-integer year))
|
|
registers))))
|
|
;; Oct 10/23 3:00 PM
|
|
(def "([A-Za-z]+)(?:\\s+|/)([0-9]{1,2})(?:(?:\\s+|/)([0-9]+))?"
|
|
(lambda (source registers)
|
|
(destructuring-bind (month-str day year &rest ignore)
|
|
registers
|
|
(declare (ignore ignore))
|
|
(let ((month (parse-month-string month-str)))
|
|
(unless month
|
|
(error 'date-parse-error
|
|
:source source
|
|
:message (format nil "unknown month: ~S" month-str)))
|
|
(add-time-registers source
|
|
(local-time:encode-timestamp
|
|
0 0 0 0
|
|
(parse-integer day)
|
|
month
|
|
(if year
|
|
(parse-integer year)
|
|
(current-year)))
|
|
registers))))))))
|
|
|
|
(defun parse-date-time (string)
|
|
"Parse date and time from STRING."
|
|
(dolist (entry *date-parse-formats*)
|
|
(destructuring-bind (scanner . func) entry
|
|
(multiple-value-bind (start end reg-starts reg-ends)
|
|
(cl-ppcre:scan scanner string)
|
|
(when (and (eql start 0)
|
|
(eql end (length string)))
|
|
(return-from parse-date-time
|
|
(funcall func
|
|
string
|
|
(loop for s across reg-starts
|
|
for e across reg-ends
|
|
when (and s e)
|
|
collect (subseq string s e)
|
|
else
|
|
collect nil))))))))
|
|
|
|
(defun parse-date-range (string)
|
|
"Parse a date range from STRING."
|
|
(let ((sep (search ".." string)))
|
|
(when (not sep)
|
|
(error 'date-parse-error
|
|
:source string
|
|
:message "expected \"..\" to separate start and end date"))
|
|
(let ((second-sep (search ".." string :start2 (1+ sep))))
|
|
(when second-sep
|
|
(error 'date-parse-error :source string
|
|
:position second-sep
|
|
:message "multiple \"..\" found")))
|
|
(macrolet ((trim (str)
|
|
`(string-trim '(#\Tab #\Space #\Newline) ,str)))
|
|
(cons (parse-date-time (trim (subseq string 0 sep)))
|
|
(parse-date-time (trim (subseq string (+ sep 2))))))))
|
|
|
|
(defun timestamp-in-ranges (stamp ranges)
|
|
"Return non-nil if STAMP is in one of RANGES."
|
|
(some (lambda (range)
|
|
(destructuring-bind (start . end) range
|
|
(when (local-time:timestamp> start end)
|
|
(rotatef start end))
|
|
(and (local-time:timestamp>= stamp start)
|
|
(local-time:timestamp<= stamp end))))
|
|
ranges))
|
|
|
|
(defclass option-multi-parsed (clingon:option)
|
|
((parser :accessor option-multi-parsed-parser
|
|
:initarg :parser
|
|
:type (function (string) t)
|
|
:documentation "The function that parses the passed value.")
|
|
(values :accessor option-multi-parsed-values
|
|
:initform nil
|
|
:type list
|
|
:documentation "The list of parsed values passed by the user."))
|
|
(:default-initargs :parameter "VALUE")
|
|
(:documentation "An option type that parses each value passed by the user."))
|
|
|
|
(defmethod clingon:derive-option-value ((option option-multi-parsed) arg &key)
|
|
(with-slots (parser values) option
|
|
(push (funcall parser arg) values)))
|
|
|
|
(defmethod clingon:finalize-option ((option option-multi-parsed) &key)
|
|
(with-slots (values) option
|
|
(setq values (nreverse values))))
|
|
|
|
(defmethod clingon:make-option ((kind (eql :multi-parsed)) &rest args)
|
|
(apply #'make-instance 'option-multi-parsed args))
|
|
|
|
(defclass option-date-range (option-multi-parsed)
|
|
()
|
|
(:default-initargs :parameter "RANGE" :parser #'parse-date-range))
|
|
|
|
(defmethod clingon:make-option ((kind (eql :date-range)) &rest args)
|
|
(apply #'make-instance 'option-date-range args))
|