master f99a0dae7ca 5/5: Align date stamps to whole days in ERC

[F. Jason Park]

branch: master
commit f99a0dae7ca1c5fe5232dafd7b1290b3435ad526
Author: F. Jason Park <jp@neverwas.me>
Commit: F. Jason Park <jp@neverwas.me>

    Align date stamps to whole days in ERC
    
    * lisp/erc/erc-stamp.el (erc-stamp--current-time): Ditch overriding
    precedence of the `erc--ts' property in `:around' method because the
    variable `erc-stamp--current-time' fills that role well enough.
    (erc-stamp--current-datestamp-left): Remove unused variable.
    (erc-stamp--insert-date-stamp-as-phony-message): Assume
    `erc-timestamp-last-inserted-left' has already been assigned the
    updated rendered stamp for the current time.
    (erc-stamp--lr-date-on-pre-modify): Use the variable
    `erc-stamp--current-time' instead of the `erc-ts' property to convey
    an overriding time value for `erc-add-timestamp'.  Set
    `erc-timestamp-last-inserted-left' instead of fiddling with another
    temporary variable to hack around these ill-fitting interfaces.  Use
    day-aligned time value for the `erc-ts' property assigned to date
    stamps.
    (erc-stamp--date-mode): New internal minor mode.
    (erc-insert-timestamp-left-and-right): Defer to `erc-stamp--date-mode'
    for setting up date-stamp specific hooks.
    (erc-stamp--time-as-day): New function to "round" a date stamp to
    start of local day.
    (erc-stamp--setup): Defer to `erc-stamp--date-mode' for date-stamp
    specific teardown.  (Bug#60936)
    * test/lisp/erc/erc-fill-tests.el
    (erc-fill-tests--current-time-value): Change default value to nil.
    (erc-stamp--current-time): New method for test cases.
    (erc-fill-tests--insert-privmsg): Use realistic value for `unparsed'
    slot.
    (erc-fill-tests--wrap-populate): Bind
    `erc-fill-tests--current-time-value' to 0.  Don't mock the function
    `erc-stamp--current-time' because doing so inhibits normal polymorphic
    dispatch, which test cases rely on for delivering correct timestamp
    values in varied contexts.
    ; * test/lisp/erc/resources/fill/snapshots/merge-01-start.eld: Update.
    ; * test/lisp/erc/resources/fill/snapshots/merge-02-right.eld: Update.
    ; * test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld: Update.
---
 lisp/erc/erc-stamp.el                              | 87 ++++++++++++++++------
 test/lisp/erc/erc-fill-tests.el                    | 15 ++--
 .../resources/fill/snapshots/merge-01-start.eld    |  2 +-
 .../resources/fill/snapshots/merge-02-right.eld    |  2 +-
 .../erc/resources/fill/snapshots/merge-wrap-01.eld |  2 +-
 5 files changed, 77 insertions(+), 31 deletions(-)

diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 71036a9a853..e23380eb936 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -216,9 +216,7 @@ This becomes the message's `erc-ts' text property."
   (erc-compat--current-lisp-time))
 
 (cl-defmethod erc-stamp--current-time :around ()
-  (or erc-stamp--current-time
-      (and erc--msg-props (gethash 'erc-ts erc--msg-props))
-      (cl-call-next-method)))
+  (or erc-stamp--current-time (cl-call-next-method)))
 
 (defvar erc-stamp--skip nil
   "Non-nil means inhibit `erc-add-timestamp' completely.")
@@ -653,9 +651,6 @@ value of t means the option's value doesn't require 
trimming.")
   (erc--hide-message 'timestamp)
   (run-hooks 'erc-stamp--insert-date-hook))
 
-;; A kludge to pass state from insert hook to nested insert hook.
-(defvar erc-stamp--current-datestamp-left nil)
-
 (defun erc-stamp--format-date-stamp (ct)
   "Format left date stamp with `erc-timestamp-format-left'."
   (unless erc-stamp--date-format-end
@@ -676,7 +671,7 @@ value of t means the option's value doesn't require 
trimming.")
 ;; adjust invisibility props.
 (defun erc-stamp--insert-date-stamp-as-phony-message (string)
   (cl-assert (string-empty-p string))
-  (setq string erc-stamp--current-datestamp-left)
+  (setq string erc-timestamp-last-inserted-left)
   (let ((erc-stamp--skip t)
         (erc-insert-modify-hook `(,@erc-insert-modify-hook
                                   erc-stamp--propertize-left-date-stamp))
@@ -684,27 +679,59 @@ value of t means the option's value doesn't require 
trimming.")
         ;; Don't run hooks that aren't expecting a narrowed buffer.
         (erc-insert-pre-hook nil)
         (erc-insert-done-hook nil))
-    (erc-display-message nil nil (current-buffer) string)
-    (setq erc-timestamp-last-inserted-left string)))
+    (erc-display-message nil nil (current-buffer) string)))
 
 (defun erc-stamp--lr-date-on-pre-modify (_)
-  (when-let ((ct (erc-stamp--current-time))
+  (when-let (((not erc-stamp--skip))
+             (ct (erc-stamp--current-time))
              (rendered (erc-stamp--format-date-stamp ct))
              ((not (string-equal rendered erc-timestamp-last-inserted-left)))
-             (erc-stamp--current-datestamp-left rendered)
              (erc-insert-timestamp-function
               #'erc-stamp--insert-date-stamp-as-phony-message))
     (save-excursion
       (save-restriction
         (narrow-to-region (or erc--insert-marker erc-insert-marker)
                           (or erc--insert-marker erc-insert-marker))
-        ;; Forget current `erc-cmd', etc.
-        (let ((erc--msg-props
-               (map-into `((erc-msg . datestamp)
-                           (erc-ts . ,(erc-stamp--current-time)))
-                         'hash-table))
-              erc-timestamp-format erc-away-timestamp-format)
-          (erc-add-timestamp))))))
+        ;; Ensure all hooks, like `erc-stamp--insert-date-hook', only
+        ;; see the let-bound value below during `erc-add-timestamp'.
+        (setq erc-timestamp-last-inserted-left nil)
+        (let* ((aligned (erc-stamp--time-as-day ct))
+               (erc-stamp--current-time aligned)
+               ;; Forget current `erc-cmd', etc.
+               (erc--msg-props (map-into `((erc-msg . datestamp))
+                                         'hash-table))
+               (erc-timestamp-last-inserted-left rendered)
+               erc-timestamp-format erc-away-timestamp-format)
+          ;; FIXME delete once convinced adjustment correct.
+          (cl-assert (string= rendered
+                              (erc-stamp--format-date-stamp aligned)))
+          (erc-add-timestamp))
+        (setq erc-timestamp-last-inserted-left rendered)))))
+
+;; This minor mode is just a placeholder and currently unhelpful for
+;; managing complexity.  A useful version would leave a marker during
+;; post-modify hooks and then perform insertions (before markers)
+;; during "done" hooks.  This would enable completely decoupling from
+;; and possibly deprecating `erc-insert-timestamp-left-and-right'.
+;; However, doing this would require expanding the internal API to
+;; include insertion and deletion handlers for twiddling and massaging
+;; text properties based on context immediately after modifying text
+;; earlier in a buffer (away from `erc-insert-marker').  Without such
+;; handlers, things like "merged" `fill-wrap' speakers and invisible
+;; messages may be damaged by buffer modifications.
+(define-minor-mode erc-stamp--date-mode
+  "Insert date stamps as standalone messages."
+  :interactive nil
+  (if erc-stamp--date-mode
+      (progn (add-hook 'erc-insert-pre-hook
+                       #'erc-stamp--lr-date-on-pre-modify 10 t)
+             (add-hook 'erc-pre-send-functions
+                       #'erc-stamp--lr-date-on-pre-modify 10 t))
+    (kill-local-variable 'erc-timestamp-last-inserted-left)
+    (remove-hook 'erc-insert-pre-hook
+                 #'erc-stamp--lr-date-on-pre-modify t)
+    (remove-hook 'erc-pre-send-functions
+                 #'erc-stamp--lr-date-on-pre-modify t)))
 
 (defvar erc-stamp-prepend-date-stamps-p nil
   "When non-nil, date stamps are not independent messages.
@@ -736,9 +763,12 @@ left-sided stamps and date stamps inserted by this 
function."
               (and (or (null erc-timestamp-format-left)
                        (string-empty-p ; compat
                         (string-trim erc-timestamp-format-left "\n")))
+                   (always (erc-stamp--date-mode -1))
                    (setq erc-stamp-prepend-date-stamps-p t)))
-    (add-hook 'erc-insert-pre-hook #'erc-stamp--lr-date-on-pre-modify 10 t)
-    (add-hook 'erc-pre-send-functions #'erc-stamp--lr-date-on-pre-modify 10 t)
+    (erc-stamp--date-mode +1)
+    ;; Hooks used by ^ are the preferred means of inserting date
+    ;; stamps.  But they'll never see this inaugural message, so it
+    ;; must be handled specially.
     (let ((erc--insert-marker (point-min-marker))
           (end-marker (point-max-marker)))
       (set-marker-insertion-type erc--insert-marker t)
@@ -771,6 +801,19 @@ left-sided stamps and date stamps inserted by this 
function."
 ;; for testing: (setq erc-timestamp-only-if-changed-flag nil)
 (defvar erc-stamp--tz nil)
 
+;; Unfortunately, cursory measurements show that this function is 10x
+;; slower than `erc-format-timestamp', which is perhaps
+;; counterintuitive.  Thus, we use the latter for our cache, and
+;; perform day alignments via this function only when needed.
+(defun erc-stamp--time-as-day (current-time)
+  "Discard hour, minute, and second info from timestamp CURRENT-TIME."
+  (let* ((current-time-list) ; flag
+         (decoded (decode-time current-time erc-stamp--tz)))
+    (setf (decoded-time-second decoded) 0
+          (decoded-time-minute decoded) 0
+          (decoded-time-hour decoded) 0)
+    (encode-time decoded))) ; may return an integer
+
 (defun erc-format-timestamp (time format)
   "Return TIME formatted as string according to FORMAT.
 Return the empty string if FORMAT is nil."
@@ -843,11 +886,9 @@ Return the empty string if FORMAT is nil."
     (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible)
       (erc-munge-invisibility-spec))
     ;; Undo local mods from `erc-insert-timestamp-left-and-right'.
-    (remove-hook 'erc-insert-pre-hook #'erc-stamp--lr-date-on-pre-modify t)
-    (remove-hook 'erc-pre-send-functions #'erc-stamp--lr-date-on-pre-modify t)
+    (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left'
     (kill-local-variable 'erc-stamp--last-stamp)
     (kill-local-variable 'erc-timestamp-last-inserted)
-    (kill-local-variable 'erc-timestamp-last-inserted-left)
     (kill-local-variable 'erc-timestamp-last-inserted-right)
     (kill-local-variable 'erc-stamp--date-format-end)))
 
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
index 8179cbda2cb..c21f3935503 100644
--- a/test/lisp/erc/erc-fill-tests.el
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -27,13 +27,19 @@
 (require 'erc-fill)
 
 (defvar erc-fill-tests--buffers nil)
-(defvar erc-fill-tests--current-time-value 0)
+(defvar erc-fill-tests--current-time-value nil)
+
+(cl-defmethod erc-stamp--current-time
+  (&context (erc-fill-tests--current-time-value integer))
+  erc-fill-tests--current-time-value)
 
 (defun erc-fill-tests--insert-privmsg (speaker &rest msg-parts)
   (declare (indent 1))
   (let* ((msg (erc-format-privmessage speaker
                                       (apply #'concat msg-parts) nil t))
-         (parsed (make-erc-response :unparsed msg :sender speaker
+         (parsed (make-erc-response :unparsed (format ":%s PRIVMSG #chan :%s"
+                                                      speaker msg)
+                                    :sender speaker
                                     :command "PRIVMSG"
                                     :command-args (list "#chan" msg)
                                     :contents msg)))
@@ -45,12 +51,11 @@
         (erc-fill-function 'erc-fill-wrap)
         (pre-command-hook pre-command-hook)
         (inhibit-message noninteractive)
+        (erc-fill-tests--current-time-value 0)
         erc-insert-post-hook
         extended-command-history
         erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
-    (cl-letf (((symbol-function 'erc-stamp--current-time)
-               (lambda () erc-fill-tests--current-time-value))
-              ((symbol-function 'erc-server-connect)
+    (cl-letf (((symbol-function 'erc-server-connect)
                (lambda (&rest _)
                  (setq erc-server-process
                        (start-process "sleep" (current-buffer) "sleep" "1"))
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld 
b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
index 8a6f2289f5d..c07eee3517f 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<alic [...]
+#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<alic [...]
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld 
b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
index 3eb4be4919b..cf5cdb4f825 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<alic [...]
+#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<alic [...]
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld 
b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
index f966daeed1f..ad4e6483f01 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<bob> [...]
\ No newline at end of file
+#("\n\n\n[Thu Jan  1 1970]\n*** This server is in debug mode and is logging 
all user I/O. If you do not wish for everything you send to be readable by the 
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a 
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause 
to complain of? Come me to what was done to her.\n<bob> alice: Either your 
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr  1 
2023]\n<bob> zero.[07:00]\n<bob> [...]