compat-31: New extended function seconds-to-string

4 files changed, 130 insertions, 0 deletions

diff --git a/NEWS.org b/NEWS.org
index e365a6e..2c9f0de 100644
--- a/NEWS.org
+++ b/NEWS.org
@@ -11,6 +11,7 @@
 - compat-31: New function =completion-table-with-metadata=.
 - compat-31: New function =completion-list-candidate-at-point=.
 - compat-31: New macro =with-work-buffer=.
+- compat-31: New extended function =seconds-to-string=.
 - Drop support for Emacs 24.x. Emacs 25.1 is required now. In case
   Emacs 24.x support is still needed, Compat 30 can be used.
 
diff --git a/compat-31.el b/compat-31.el
index 53b94e4..57c263c 100644
--- a/compat-31.el
+++ b/compat-31.el
@@ -83,6 +83,93 @@ For instance:
       (push (+ (* (nth i a) alpha) (* (nth i b) (- 1 alpha))) blend))
     (nreverse blend)))
 
+;;;; Defined in time-date.el
+
+(compat-defvar seconds-to-string ;; <compat-tests:seconds-to-string>
+  (list (list 1 "ms" 0.001)
+        (list 100 "s" 1)
+        (list (* 60 100) "m" 60.0)
+        (list (* 3600 30) "h" 3600.0)
+        (list (* 3600 24 400) "d" (* 3600.0 24.0))
+        (list nil "y" (* 365.25 24 3600)))
+  "Formatting used by the function `seconds-to-string'.")
+
+(compat-defvar seconds-to-string-readable ;; <compat-tests:seconds-to-string>
+  `(("Y" "year"   "years"   ,(round (* 60 60 24 365.2425)))
+    ("M" "month"  "months"  ,(round (* 60 60 24 30.436875)))
+    ("w" "week"   "weeks"   ,(* 60 60 24 7))
+    ("d" "day"    "days"    ,(* 60 60 24))
+    ("h" "hour"   "hours"   ,(* 60 60))
+    ("m" "minute" "minutes" 60)
+    ("s" "second" "seconds" 1))
+  "Formatting used by the function `seconds-to-string' with READABLE set.
+The format is an alist, with string keys ABBREV-UNIT, and elements like:
+
+  (ABBREV-UNIT UNIT UNIT-PLURAL SECS)
+
+where UNIT is a unit of time, ABBREV-UNIT is the abbreviated form of
+UNIT, UNIT-PLURAL is the plural form of UNIT, and SECS is the number of
+seconds per UNIT.")
+
+(compat-defun seconds-to-string (delay &optional readable abbrev precision) ;; <compat-tests:seconds-to-string>
+  "Handle optional arguments READABLE, ABBREV and PRECISION."
+  :extended t
+  (cond
+   ((< delay 0)
+    (concat "-" (seconds-to-string (- delay) readable precision)))
+   (readable
+    (let* ((stsa seconds-to-string-readable)
+           (expanded (eq readable 'expanded))
+           digits
+           (round-to (cond
+                      ((wholenump precision)
+                       (setq digits precision)
+                       (expt 10 (- precision)))
+                      ((and (floatp precision) (< precision 1.))
+                       (setq digits (- (floor (log precision 10))))
+                       precision)
+                      (t (setq digits 0) 1)))
+           (dformat (if (> digits 0) (format "%%0.%df" digits)))
+           (padding (if abbrev "" " "))
+           here cnt cnt-pre here-pre cnt-val isfloatp)
+      (if (= (round delay round-to) 0)
+          (format "0%s" (if abbrev "s" " seconds"))
+        (while (and (setq here (pop stsa)) stsa
+                    (< (/ delay (nth 3 here)) 1)))
+        (or (and
+             expanded stsa 	; smaller unit remains
+             (progn
+               (setq
+                here-pre here here (car stsa)
+                cnt-pre (floor (/ (float delay) (nth 3 here-pre)))
+                cnt (round
+                     (/ (- (float delay) (* cnt-pre (nth 3 here-pre)))
+                        (nth 3 here))
+                     round-to))
+               (if (> cnt 0) t (setq cnt cnt-pre here here-pre here-pre nil))))
+            (setq cnt (round (/ (float delay) (nth 3 here)) round-to)))
+        (setq cnt-val (* cnt round-to)
+              isfloatp (and (> digits 0)
+                            (> (- cnt-val (floor cnt-val)) 0.)))
+        (cl-labels
+            ((unit (val here &optional plural)
+               (cond (abbrev (car here))
+                     ((and (not plural) (<= (floor val) 1)) (nth 1 here))
+                     (t (nth 2 here)))))
+          (concat
+           (when here-pre
+             (concat (number-to-string cnt-pre) padding
+                     (unit cnt-pre here-pre) " "))
+           (if isfloatp (format dformat cnt-val)
+             (number-to-string (floor cnt-val)))
+           padding
+           (unit cnt-val here isfloatp)))))) ; float formats are always plural
+   ((= 0 delay) "0s")
+   (t (let ((sts seconds-to-string) here)
+        (while (and (car (setq here (pop sts)))
+                    (<= (car here) delay)))
+        (concat (format "%.2f" (/ delay (car (cddr here)))) (cadr here))))))
+
 ;;;; Defined in minibuffer.el
 
 (compat-defun completion-list-candidate-at-point (&optional pt) ;; <compat-tests:completion-list-candidate-at-point>
diff --git a/compat-tests.el b/compat-tests.el
index a7d7eb0..da1b98b 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -2712,6 +2712,25 @@
   (should-equal '(nil nil nil 9 4 2020 nil nil nil) (date-ordinal-to-time 2020 100))
   (should-equal '(nil nil nil 19 7 2021 nil nil nil) (date-ordinal-to-time 2021 200)))
 
+(ert-deftest compat-seconds-to-string ()
+  (should-equal (compat-call seconds-to-string 0) "0s")
+  (should-equal (compat-call seconds-to-string 9) "9.00s")
+  (should-equal (compat-call seconds-to-string 99) "99.00s")
+  (should-equal (compat-call seconds-to-string 999) "16.65m")
+  (should-equal (compat-call seconds-to-string 9999) "2.78h")
+  (should-equal (compat-call seconds-to-string 99999) "27.78h")
+  (should-equal (compat-call seconds-to-string 999999) "11.57d")
+  (should-equal (compat-call seconds-to-string 9999999) "115.74d")
+  (should-equal (compat-call seconds-to-string 99999999) "3.17y")
+  (should-equal (compat-call seconds-to-string 999999999) "31.69y")
+  ;; New functionality
+  (should-equal (compat-call seconds-to-string 999 'readable) "17 minutes")
+  (should-equal (compat-call seconds-to-string 999 'readable 'abbrev) "17m")
+  (should-equal (compat-call seconds-to-string 999 'readable 'abbrev 2) "16.65m")
+  (should-equal (compat-call seconds-to-string 999999 'readable) "2 weeks")
+  (should-equal (compat-call seconds-to-string 999999 'readable 'abbrev) "2w")
+  (should-equal (compat-call seconds-to-string 999999 'readable 'abbrev 4) "1.6534w"))
+
 (ert-deftest compat-regexp-opt ()
   ;; Ensure `regexp-opt' doesn't change the existing
   ;; behaviour:
diff --git a/compat.texi b/compat.texi
index 72faca7..6d7842a 100644
--- a/compat.texi
+++ b/compat.texi
@@ -3427,6 +3427,29 @@ older than 31.1.  Note that due to upstream changes, it might happen
 that there will be the need for changes, so use these functions with
 care.
 
+@c copied from lispref/os.texi
+@defun compat-call@ seconds-to-string delay &optional readable abbrev precision
+Return a string describing a given @var{delay} (in seconds).  By
+default, this function formats the returned string as a floating-point
+number in units selected according to the value of @var{delay}.  For
+example, a delay of 9861.5 seconds yields @samp{2.74h}, since the value
+of @var{delay} is longer than 1 hour, but shorter than 1 day.  The
+output formatting can be further controlled by the optional arguments,
+if optional argument @var{readable} is non-@code{nil}.  If
+@var{readable}'s value is @code{expanded}, the returned string will
+describe @var{delay} using two units; for example, a delay of 9861.5
+seconds with @var{readable} set to the symbol @code{expanded} returns
+@samp{2 hours 44 minutes}, but if @var{readable} is @code{t}, the
+function returns @samp{3 hours}.  Optional argument @var{abbrev}, if
+non-@code{nil}, means to abbreviate the units: use @samp{h} instead of
+@samp{hours}, @samp{m} instead of @samp{minutes}, etc.  If
+@var{precision} is a whole integer number, the function rounds the value
+of the smallest unit it produces to that many digits after the decimal
+point; thus, 9861.5 with @var{precision} set to 3 yields @samp{2.739
+hours}.  If @var{precision} is a non-negative float smaller than 1, the
+function rounds to that value.
+@end defun
+
 @c based on lisp/minibuffer.el
 @defun completion-table-with-metadata table metadata
 Return new completion @var{table} with @var{metadata}.  @var{metadata}