Finish all features (for now)
This commit is contained in:
264
clash/parse-date.lisp
Normal file
264
clash/parse-date.lisp
Normal file
@ -0,0 +1,264 @@
|
||||
(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))
|
||||
Reference in New Issue
Block a user