(require 'cl-lib)
(require 'dash)
(require 's)
(defvar ts-default-format "%Y-%m-%d %H:%M:%S %z"
"Default format for `ts-format'.")
(cl-defmacro ts-defstruct (&rest args)
"Like `cl-defstruct', but with additional slot options from ARGS.
Additional slot options and values:
`:accessor-init': a sexp that initializes the slot in the
accessor if the slot is nil. The symbol `struct' will be bound
to the current struct. The accessor is defined after the struct
is fully defined, so it may refer to the struct
definition (e.g. by using the `cl-struct' `pcase' macro).
`:aliases': A list of symbols which will be aliased to the slot
accessor, prepended with the struct name (e.g. a struct `ts' with
slot `year' and alias `y' would create an alias `ts-y')."
(declare (indent defun))
(let* ((struct-name (car args))
(struct-slots (cdr args))
(cl-defstruct-expansion (macroexpand `(cl-defstruct ,struct-name ,@struct-slots)))
accessor-forms alias-forms)
(cl-loop for slot in struct-slots
for pos from 1
when (listp slot)
do (-let* (((slot-name _slot-default . slot-options) slot)
((&keys :accessor-init :aliases) slot-options)
(accessor-name (intern (concat (symbol-name struct-name) "-" (symbol-name slot-name))))
(accessor-docstring (format "Access slot \"%s\" of `%s' struct STRUCT."
slot-name struct-name))
(struct-pred (intern (concat (symbol-name struct-name) "-p")))
(accessor-form `(cl-defsubst ,accessor-name (struct)
,accessor-docstring
(or (,struct-pred struct)
(signal 'wrong-type-argument
(list ',struct-name struct)))
,(when accessor-init
`(unless (aref struct ,pos)
(aset struct ,pos ,accessor-init)))
(aref struct ,pos))))
(push accessor-form accessor-forms)
(cl-loop for form in-ref cl-defstruct-expansion
do (pcase form
(`(cl-defsubst ,(and accessor (guard (eq accessor accessor-name)))
. ,_)
accessor (setf form nil))))
(cl-loop for alias in aliases
for alias-name = (intern (concat (symbol-name struct-name) "-" (symbol-name alias)))
do (push `(defalias ',alias-name ',accessor-name) alias-forms))
))
`(progn
,cl-defstruct-expansion
,@accessor-forms
,@alias-forms)))
(ts-defstruct ts
(hour
nil :accessor-init (string-to-number (format-time-string "%H" (ts-unix struct)))
:aliases (H)
:constructor "%H"
:type integer)
(minute
nil :accessor-init (string-to-number (format-time-string "%M" (ts-unix struct)))
:aliases (min M)
:constructor "%M"
:type integer)
(second
nil :accessor-init (string-to-number (format-time-string "%S" (ts-unix struct)))
:aliases (sec S)
:constructor "%S"
:type integer)
(day
nil :accessor-init (string-to-number (format-time-string "%d" (ts-unix struct)))
:aliases (day-of-month-num dom d)
:constructor "%d"
:type integer)
(month
nil :accessor-init (string-to-number (format-time-string "%m" (ts-unix struct)))
:aliases (month-num moy m)
:constructor "%m"
:type integer)
(year
nil :accessor-init (string-to-number (format-time-string "%Y" (ts-unix struct)))
:aliases (Y)
:constructor "%Y"
:type integer)
(dow
nil :accessor-init (string-to-number (format-time-string "%w" (ts-unix struct)))
:aliases (day-of-week-num)
:constructor "%w"
:type integer)
(day-abbr
nil :accessor-init (format-time-string "%a" (ts-unix struct))
:aliases (day-of-week-abbr)
:constructor "%a")
(day-name
nil :accessor-init (format-time-string "%A" (ts-unix struct))
:aliases (day-of-week-name)
:constructor "%A")
(doy
nil :accessor-init (string-to-number (format-time-string "%j" (ts-unix struct)))
:aliases (day-of-year)
:constructor "%j"
:type integer)
(woy
nil :accessor-init (string-to-number (format-time-string "%V" (ts-unix struct)))
:aliases (week week-of-year)
:constructor "%V"
:type integer)
(month-abbr
nil :accessor-init (format-time-string "%b" (ts-unix struct))
:aliases (b)
:constructor "%b")
(month-name
nil :accessor-init (format-time-string "%B" (ts-unix struct))
:aliases (B)
:constructor "%B")
(tz-abbr
nil :accessor-init (format-time-string "%Z" (ts-unix struct))
:constructor "%Z")
(tz-offset
nil :accessor-init (format-time-string "%z" (ts-unix struct))
:constructor "%z")
(internal
nil :accessor-init (apply #'encode-time (decode-time (ts-unix struct))))
(unix
nil :accessor-init (pcase-let* (((cl-struct ts second minute hour day month year) struct))
(if (and second minute hour day month year)
(float-time (encode-time second minute hour day month year))
(float-time)))))
(defun ts-now ()
"Return `ts' struct set to now.
This is a non-inlined function, so it may be rebound, e.g. with
`cl-letf' for testing."
(make-ts :unix (float-time)))
(defsubst ts-format (&optional ts-or-format-string ts)
"Format timestamp with `format-time-string'.
If TS-OR-FORMAT-STRING is a timestamp or nil, use the value of
`ts-default-format'. If both TS-OR-FORMAT-STRING and TS are nil,
use the current time."
(cl-etypecase ts-or-format-string
(ts (format-time-string ts-default-format (ts-unix ts-or-format-string)))
(string (cl-etypecase ts
(ts (format-time-string ts-or-format-string (ts-unix ts)))
(null (format-time-string ts-or-format-string))))
(null (cl-etypecase ts
(ts (format-time-string ts-default-format (ts-unix ts)))
(null (format-time-string ts-default-format))))))
(defsubst ts-parse (string)
"Return new `ts' struct, parsing STRING with `parse-time-string'."
(let ((parsed (parse-time-string string)))
(cl-loop for i from 0 to 5
when (null (nth i parsed))
do (setf (nth i parsed) 0))
(->> parsed
(apply #'encode-time)
float-time
(make-ts :unix))))
(defsubst ts-parse-fill (fill string)
"Return new `ts' struct, parsing STRING with `parse-time-string'.
Empty hour/minute/second values are filled according to FILL: if
`begin', with 0; if `end', hour is filled with 23 and
minute/second with 59; if nil, an error may be signaled when time
values are empty.
Note that when FILL is `end', a time value like \"12:12\" is
filled to \"12:12:00\", not \"12:12:59\"."
(let ((parsed (parse-time-string string)))
(pcase-exhaustive fill
('begin (unless (nth 0 parsed)
(setf (nth 0 parsed) 0))
(unless (nth 1 parsed)
(setf (nth 1 parsed) 0))
(unless (nth 2 parsed)
(setf (nth 2 parsed) 0)))
('end (unless (nth 0 parsed)
(setf (nth 0 parsed) 59))
(unless (nth 1 parsed)
(setf (nth 1 parsed) 59))
(unless (nth 2 parsed)
(setf (nth 2 parsed) 23)))
(`nil nil))
(->> parsed
(apply #'encode-time)
float-time
(make-ts :unix))))
(defsubst ts-reset (ts)
"Return TS with all slots cleared except `unix'.
Non-destructive. The same as:
(make-ts :unix (ts-unix ts))"
(make-ts :unix (ts-unix ts)))
(defsubst ts-update (ts)
"Return timestamp TS after updating its Unix timestamp from its other slots.
Non-destructive. To be used after setting slots with,
e.g. `ts-fill'."
(pcase-let* (((cl-struct ts second minute hour day month year) ts))
(make-ts :unix (float-time (encode-time second minute hour day month year)))))
(defsubst ts-parse-org-element (element)
"Return timestamp object for Org timestamp element ELEMENT.
Element should be like one parsed by `org-element', the first
element of which is `timestamp'. Assumes timestamp is not a
range."
(-let (((_ (&keys :year-start :month-start :day-start :hour-start :minute-start)) element))
(make-ts :year year-start :month month-start :day day-start
:hour (or hour-start 0) :minute (or minute-start 0) :second 0)))
(declare-function org-parse-time-string "org-macs.el")
(defsubst ts-parse-org (org-ts-string)
"Return timestamp object for Org timestamp string ORG-TS-STRING.
Note that function `org-parse-time-string' is called, which
should be loaded before calling this function."
(pcase-let* ((`(,second ,minute ,hour ,day ,month ,year)
(save-match-data
(org-parse-time-string org-ts-string))))
(make-ts :second second :minute minute :hour hour :day day :month month :year year)))
(defsubst ts-parse-org-fill (fill org-ts-string)
"Return timestamp object for Org timestamp string ORG-TS-STRING.
Note that function `org-parse-time-string' is called, which
should be loaded before calling this function.
Hour/minute/second values are filled according to FILL: if
`begin', with 0; if `end', hour is filled with 23 and
minute/second with 59. Note that `org-parse-time-string' does
not support timestamps that contain seconds."
(pcase-let* ((`(,second ,minute ,hour ,day ,month ,year)
(org-parse-time-string org-ts-string 'nodefault)))
(pcase-exhaustive fill
('begin (unless second
(setf second 0))
(unless minute
(setf minute 0))
(unless hour
(setf hour 0)))
('end (if (not (or hour minute))
(progn
(setf second 59
minute 59
hour 23))
(unless second
(setf second 59))
(unless minute
(setf minute 59))
(unless hour
(setf hour 23))))
(_ (error "FILL must be `begin' or `end'")))
(make-ts :second second :minute minute :hour hour :day day :month month :year year)))
(cl-defun ts-apply (&rest args)
"Return new timestamp based on TS with new slot values from ARGS.
Fill timestamp slots, overwrite given slot values, and return new
timestamp with Unix timestamp value derived from new slot values.
SLOTS is a list of alternating key-value pairs like that passed
to `make-ts'."
(declare (advertised-calling-convention (&rest slots ts) nil))
(-let* (((&keys :second :minute :hour :day :month :year) args)
(ts (-last-item args)))
(setf ts (ts-fill ts))
(when second
(setf (ts-second ts) second))
(when minute
(setf (ts-minute ts) minute))
(when hour
(setf (ts-hour ts) hour))
(when day
(setf (ts-day ts) day))
(when month
(setf (ts-month ts) month))
(when year
(setf (ts-year ts) year))
(ts-update ts)))
(defmacro ts-define-fill ()
"Define function that fills all applicable slots of a `ts' from its `unix' slot."
(let* ((slots (->> (cl-struct-slot-info 'ts)
(--select (and (not (member (car it) '(unix internal cl-tag-slot)))
(plist-get (cddr it) :constructor)))
(--map (list (intern (concat ":" (symbol-name (car it))))
(cddr it)))))
(keywords (-map #'car slots))
(constructors (->> slots
(--map (plist-get (cadr it) :constructor))
-non-nil))
(types (--map (plist-get (cadr it) :type) slots))
(format-string (s-join "\f" constructors))
(value-conversions (cl-loop for type in types
for keyword in keywords
for i from 0
for val = `(nth ,i time-values)
append (list keyword (pcase type
('integer `(string-to-number ,val))
(_ val))))))
`(defun ts-fill (ts &optional zone)
"Return TS having filled all slots from its Unix timestamp.
This is non-destructive. ZONE is passed to `format-time-string',
which see."
(let ((time-values (save-match-data
(split-string (format-time-string ,format-string (ts-unix ts) zone) "\f"))))
(make-ts :unix (ts-unix ts) ,@value-conversions)))))
(ts-define-fill)
(defun ts-difference (a b)
"Return difference in seconds between timestamps A and B."
(- (ts-unix a) (ts-unix b)))
(defalias 'ts-diff 'ts-difference)
(defun ts-human-duration (seconds)
"Return plist describing duration SECONDS.
List includes years, days, hours, minutes, and seconds. This is
a simple calculation that does not account for leap years, leap
seconds, etc."
(cl-macrolet ((dividef (place divisor)
`(prog1 (/ ,place ,divisor)
(setf ,place (% ,place ,divisor)))))
(let* ((seconds (floor seconds))
(years (dividef seconds 31536000))
(days (dividef seconds 86400))
(hours (dividef seconds 3600))
(minutes (dividef seconds 60)))
(list :years years :days days :hours hours :minutes minutes :seconds seconds))))
(cl-defun ts-human-format-duration (seconds &optional abbreviate)
"Return human-formatted string describing duration SECONDS.
If SECONDS is less than 1, returns \"0 seconds\". If ABBREVIATE
is non-nil, return a shorter version, without spaces. This is a
simple calculation that does not account for leap years, leap
seconds, etc."
(if (< seconds 1)
(if abbreviate "0s" "0 seconds")
(cl-macrolet ((format> (place)
`(when (> ,place 0)
(format "%d%s%s" ,place
(if abbreviate "" " ")
(if abbreviate
,(substring (symbol-name place) 0 1)
,(symbol-name place)))))
(join-places (&rest places)
`(->> (list ,@(cl-loop for place in places
collect `(format> ,place)))
-non-nil
(s-join (if abbreviate "" ", ")))))
(-let* (((&plist :years :days :hours :minutes :seconds) (ts-human-duration seconds)))
(join-places years days hours minutes seconds)))))
(defun ts-adjust (&rest adjustments)
"Return new timestamp having applied ADJUSTMENTS to TS.
ADJUSTMENTS should be a series of alternating SLOTS and VALUES by
which to adjust them. For example, this form returns a new
timestamp that is 47 hours into the future:
(ts-adjust 'hour -1 'day +2 (ts-now))
Since the timestamp argument is last, it's suitable for use in a
threading macro."
(declare (advertised-calling-convention (&rest adjustments ts) nil))
(let* ((ts (-last-item adjustments))
(adjustments (nbutlast adjustments))
(ts (ts-fill ts)))
(cl-loop for (slot change) on adjustments by #'cddr
do (cl-incf (cl-struct-slot-value 'ts slot ts) change))
(ts-update ts)))
(defsubst ts-inc (slot value ts)
"Return a new timestamp based on TS with its SLOT incremented by VALUE.
SLOT should be specified as a plain symbol, not a keyword."
(setq ts (ts-fill ts))
(cl-incf (cl-struct-slot-value 'ts slot ts) value)
(ts-update ts))
(defsubst ts-dec (slot value ts)
"Return a new timestamp based on TS with its SLOT decremented by VALUE.
SLOT should be specified as a plain symbol, not a keyword."
(setq ts (ts-fill ts))
(cl-decf (cl-struct-slot-value 'ts slot ts) value)
(ts-update ts))
(defmacro ts-adjustf (ts &rest adjustments)
"Return timestamp TS having applied ADJUSTMENTS.
This function is destructive, as it calls `setf' on TS.
ADJUSTMENTS should be a series of alternating SLOTS and VALUES by
which to adjust them. For example, this form adjusts a timestamp
to 47 hours into the future:
(let ((ts (ts-now)))
(ts-adjustf ts 'hour -1 'day +2))"
`(progn
(setf ,ts (ts-fill ,ts))
,@(cl-loop for (slot change) on adjustments by #'cddr
for accessor = (intern (concat "ts-" (symbol-name (cadr slot))))
collect `(cl-incf (,accessor ,ts) ,change))
(setf ,ts (ts-update ,ts))))
(cl-defmacro ts-incf (place &optional (value 1))
"Increment `ts' PLACE by VALUE (default 1) and return the new value of PLACE.
Updates its `unix' slot accordingly."
`(progn
(setf ,(cadr place) (ts-fill ,(cadr place)))
(prog1
(cl-incf ,place ,value)
(setf ,(cadr place)
(ts-update ,(cadr place))))))
(cl-defmacro ts-decf (place &optional (value 1))
"Decrement `ts' PLACE by VALUE (default 1) and return the new value of PLACE.
Updates its `unix' slot accordingly."
`(progn
(setf ,(cadr place) (ts-fill ,(cadr place)))
(prog1
(cl-decf ,place ,value)
(setf ,(cadr place)
(ts-update ,(cadr place))))))
(defsubst ts-in (beg end ts)
"Return non-nil if TS is within range BEG to END, inclusive.
All arguments should be `ts' structs."
(and (ts<= beg ts)
(ts<= ts end)))
(defun ts= (a b)
"Return non-nil if timestamp A is the same as timestamp B.
Compares only the timestamps' `unix' slots. Note that a
timestamp's Unix slot is a float and may differ by less than one
second, causing them to be unequal even if all of the formatted
parts of the timestamp are the same."
(= (ts-unix a) (ts-unix b)))
(defun ts< (a b)
"Return non-nil if timestamp A is less than timestamp B."
(< (ts-unix a) (ts-unix b)))
(defun ts<= (a b)
"Return non-nil if timestamp A is <= timestamp B."
(<= (ts-unix a) (ts-unix b)))
(defun ts> (a b)
"Return non-nil if timestamp A is greater than timestamp B."
(> (ts-unix a) (ts-unix b)))
(defun ts>= (a b)
"Return non-nil if timestamp A is >= timestamp B."
(>= (ts-unix a) (ts-unix b)))
(provide 'ts)