master 9f6a9cef97b 29/37: Put display properties to better use in erc-stamp

[F. Jason Park]

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

    Put display properties to better use in erc-stamp
    
    * lisp/erc/erc-log.el (erc-log-filter-function): Add new value
    `erc-stamp-prefix-log-filter'.
    * lisp/erc/erc-stamp.el (erc-timestamp-use-align-to): Enhance meaning
    of option to accept numeric value for dynamically aligned right-hand
    stamps.  Use `graphic-display-p' to determine default value even
    though, as stated in the manual, terminal Emacs also supports the
    "space" display spec.
    (erc-stamp-right-margin-width): New option to determine width of right
    margin when `erc-stamp--display-margin-mode' is active or
    `erc-timestamp-use-align-to' is set to `margin'.
    (erc-stamp--display-margin-force): Add new helper function for
    `erc-stamp--display-margin-mode'.
    (erc-stamp--adjust-right-margin): New function to adjust width of
    right margin.
    (erc-stamp-prefix-log-filter): New value for `erc-log-filter-function'
    compatible with modules that activate
    `erc-stamp--display-margin-mode'.
    (erc-stamp--display-margin-mode): Add internal minor mode to help
    other modules quickly ensure left-right, display-prop-oriented stamps
    are showing correctly.  Does not support left-hand-only stamps.
    (erc-insert-aligned): Deprecate function and remove from primary
    client code path.
    (erc-stamp--inherited-props): Add internal constant to hold properties
    that should be inherited from any stamp-bearing message being
    inserted.
    (erc-insert-timestamp-right): Account for new display-related values
    of `erc-timestamp-use-align-to'.
    * test/lisp/erc/erc-stamp-tests.el (erc-timestamp-use-align-to--nil,
    erc-timestamp-use-align-to--t): Adjust spacing for new default
    right-hand stamp, `erc-format-timestamp', which lacks a leading space.
    (erc-timestamp-use-align-to--integer,
    erc-timestamp-use-align-to--margin): New tests.  (Bug#60936.)
---
 lisp/erc/erc-log.el              |   1 +
 lisp/erc/erc-stamp.el            | 136 ++++++++++++++++++++++++++++++++++++---
 test/lisp/erc/erc-stamp-tests.el |  70 ++++++++++++++++++--
 3 files changed, 191 insertions(+), 16 deletions(-)

diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el
index a44437ddcf7..2b58a7c56ed 100644
--- a/lisp/erc/erc-log.el
+++ b/lisp/erc/erc-log.el
@@ -198,6 +198,7 @@ This should ideally, be a \"catch-all\" coding system, like
 
 The function should take one argument, which is the text to filter."
   :type '(choice (function "Function")
+                 (function-item erc-stamp-prefix-log-filter)
                 (const :tag "No filtering" nil)))
 
 
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 18371320300..8bca9bdb56b 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -253,14 +253,110 @@ the correct column."
          (integer :tag "Column number")
          (const :tag "Unspecified" nil)))
 
-(defcustom erc-timestamp-use-align-to (eq window-system 'x)
+(defcustom erc-timestamp-use-align-to (and (display-graphic-p) t)
   "If non-nil, use the :align-to display property to align the stamp.
 This gives better results when variable-width characters (like
 Asian language characters and math symbols) precede a timestamp.
 
-A side effect of enabling this is that there will only be one
-space before a right timestamp in any saved logs."
-  :type 'boolean)
+This option only matters when `erc-insert-timestamp-function' is
+set to `erc-insert-timestamp-right' or that option's default,
+`erc-insert-timestamp-left-and-right'.  If the value is a
+positive integer, alignment occurs that many columns from the
+right edge.  If the value is `margin', the stamp appears in the
+right margin when visible.
+
+Enabling this option produces a side effect in that stamps aren't
+indented in saved logs.  When its value is an integer, this
+option adds a space after the end of a message if the stamp
+doesn't already start with one.  And when its value is t, it adds
+a single space, unconditionally.  And while this option never
+adds a space when its value is `margin', ERC does offer a
+workaround in `erc-stamp-prefix-log-filter', which strips
+trailing stamps from messages and puts them before every line."
+  :type '(choice boolean integer (const margin))
+  :package-version '(ERC . "5.6")) ; FIXME sync on release
+
+(defcustom erc-stamp-right-margin-width nil
+  "Width in columns of the right margin.
+When this option is nil, pretend its value is one column greater
+than the `string-width' of the formatted `erc-timestamp-format'.
+This option only matters when `erc-timestamp-use-align-to' is set
+to `margin'."
+  :package-version '(ERC . "5.6") ; FIXME sync on release
+  :type '(choice (const nil) integer))
+
+(defun erc-stamp--display-margin-force (orig &rest r)
+  (let ((erc-timestamp-use-align-to 'margin))
+    (apply orig r)))
+
+(defun erc-stamp--adjust-right-margin (cols)
+  "Adjust right margin by COLS.
+When COLS is zero, reset width to `erc-stamp-right-margin-width'
+or one col more than the `string-width' of
+`erc-timestamp-format'."
+  (let ((width
+         (if (zerop cols)
+             (or erc-stamp-right-margin-width
+                 (1+ (string-width (or erc-timestamp-last-inserted-right
+                                       (erc-format-timestamp
+                                        (current-time)
+                                        erc-timestamp-format)))))
+           (+ right-margin-width cols))))
+    (setq right-margin-width width
+          right-fringe-width 0)
+    (set-window-margins nil left-margin-width width)
+    (set-window-fringes nil left-fringe-width 0)))
+
+;;;###autoload
+(defun erc-stamp-prefix-log-filter (text)
+  "Prefix every message in the buffer with a stamp.
+Remove trailing stamps as well.  For now, hard code the format to
+\"ZNC\"-log style, which is [HH:MM:SS].  Expect to be used as a
+`erc-log-filter-function' when `erc-timestamp-use-align-to' is
+non-nil."
+  (insert text)
+  (goto-char (point-min))
+  (while
+      (progn
+        (when-let* (((< (point) (pos-eol)))
+                    (end (1- (pos-eol)))
+                    ((eq 'erc-timestamp (field-at-pos end)))
+                    (beg (field-beginning end))
+                    ;; Skip a line that's just a timestamp.
+                    ((> beg (point))))
+          (delete-region beg (1+ end)))
+        (when-let (time (get-text-property (point) 'erc-timestamp))
+          (insert (format-time-string "[%H:%M:%S] " time)))
+        (zerop (forward-line))))
+  "")
+
+(declare-function erc--remove-text-properties "erc" (string))
+
+;; If people want to use this directly, we can convert it into
+;; a local module.
+(define-minor-mode erc-stamp--display-margin-mode
+  "Internal minor mode for built-in modules integrating with `stamp'.
+It binds `erc-timestamp-use-align-to' to `margin' around calls to
+`erc-insert-timestamp-function' in the current buffer, and sets
+the right window margin to `erc-stamp-right-margin-width'.  It
+also arranges to remove most text properties when a user kills
+message text so that stamps will be visible when yanked."
+  :interactive nil
+  (if erc-stamp--display-margin-mode
+      (progn
+        (erc-stamp--adjust-right-margin 0)
+        (add-function :filter-return (local 'filter-buffer-substring-function)
+                      #'erc--remove-text-properties)
+        (add-function :around (local 'erc-insert-timestamp-function)
+                      #'erc-stamp--display-margin-force))
+    (remove-function (local 'filter-buffer-substring-function)
+                     #'erc--remove-text-properties)
+    (remove-function (local 'erc-insert-timestamp-function)
+                     #'erc-stamp--display-margin-force)
+    (kill-local-variable 'right-margin-width)
+    (kill-local-variable 'right-fringe-width)
+    (set-window-margins nil left-margin-width nil)
+    (set-window-fringes nil left-fringe-width nil)))
 
 (defun erc-insert-timestamp-left (string)
   "Insert timestamps at the beginning of the line."
@@ -279,6 +375,7 @@ space before a right timestamp in any saved logs."
 
 If `erc-timestamp-use-align-to' is t, use the :align-to display
 property to get to the POSth column."
+  (declare (obsolete "inlined and removed from client code path" "30.1"))
   (if (not erc-timestamp-use-align-to)
       (indent-to pos)
     (insert " ")
@@ -289,6 +386,8 @@ property to get to the POSth column."
 ;; Silence byte-compiler
 (defvar erc-fill-column)
 
+(defvar erc-stamp--inherited-props '(line-prefix wrap-prefix))
+
 (defun erc-insert-timestamp-right (string)
   "Insert timestamp on the right side of the screen.
 STRING is the timestamp to insert.  This function is a possible
@@ -340,12 +439,29 @@ printed just after each line's text (no alignment)."
       ;; some margin of error if what is displayed on the line differs
       ;; from the number of characters on the line.
       (setq col (+ col (ceiling (/ (- col (- (point) 
(line-beginning-position))) 1.6))))
-      (if (< col pos)
-         (erc-insert-aligned string pos)
-       (newline)
-       (indent-to pos)
-       (setq from (point))
-       (insert string))
+      ;; For compatibility reasons, the `erc-timestamp' field includes
+      ;; intervening white space unless a hard break is warranted.
+      (pcase erc-timestamp-use-align-to
+        ((and 't (guard (< col pos)))
+         (insert " ")
+         (put-text-property from (point) 'display `(space :align-to ,pos)))
+        ((pred integerp) ; (cl-type (integer 0 *))
+         (insert " ")
+         (when (eq ?\s (aref string 0))
+           (setq string (substring string 1)))
+         (let ((s (+ erc-timestamp-use-align-to (string-width string))))
+           (put-text-property from (point) 'display
+                              `(space :align-to (- right ,s)))))
+        ('margin
+         (put-text-property 0 (length string)
+                            'display `((margin right-margin) ,string)
+                            string))
+        ((guard (>= col pos)) (newline) (indent-to pos) (setq from (point)))
+        (_ (indent-to pos)))
+      (insert string)
+      (dolist (p erc-stamp--inherited-props)
+        (when-let ((v (get-text-property (1- from) p)))
+          (put-text-property from (point) p v)))
       (erc-put-text-property from (point) 'field 'erc-timestamp)
       (erc-put-text-property from (point) 'rear-nonsticky t)
       (when erc-timestamp-intangible
diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el
index 935b9e650b3..01e71e348e0 100644
--- a/test/lisp/erc/erc-stamp-tests.el
+++ b/test/lisp/erc/erc-stamp-tests.el
@@ -68,7 +68,7 @@
          (erc-display-message nil 'notice (current-buffer) "begin"))
        (goto-char (point-min))
        (should (search-forward-regexp
-                (rx "begin" (+ "\t") (* " ") " [") nil t))
+                (rx "begin" (+ "\t") (* " ") "[") nil t))
        ;; Field includes intervening spaces
        (should (eql ?n (char-before (field-beginning (point)))))
        ;; Timestamp extends to the end of the line
@@ -85,9 +85,9 @@
              (erc-timestamp-right-column 20))
          (erc-display-message nil 'notice (current-buffer)
                               "twenty characters"))
-       (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t))
+       (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t))
        ;; Field excludes leading whitespace (arguably undesirable).
-       (should (eql ?\s (char-after (field-beginning (point)))))
+       (should (eql ?\[ (char-after (field-beginning (point)))))
        ;; Timestamp extends to the end of the line.
        (should (eql ?\n (char-after (field-end (point)))))))))
 
@@ -101,7 +101,7 @@
            (erc-display-message nil nil (current-buffer) msg)))
        (goto-char (point-min))
        ;; Exactly two spaces, one from format, one added by erc-stamp.
-       (should (search-forward "msg one  [" nil t))
+       (should (search-forward "msg one [" nil t))
        ;; Field covers space between.
        (should (eql ?e (char-before (field-beginning (point)))))
        (should (eql ?\n (char-after (field-end (point))))))
@@ -112,9 +112,67 @@
          (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
            (erc-display-message nil nil (current-buffer) msg)))
        ;; Indented to pos (this is arguably a bug).
-       (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t))
+       (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t))
        ;; Field starts *after* leading space (arguably bad).
-       (should (eql ?\[ (char-after (1+ (field-beginning (point))))))
+       (should (eql ?\[ (char-after (field-beginning (point)))))
+       (should (eql ?\n (char-after (field-end (point)))))))))
+
+(ert-deftest erc-timestamp-use-align-to--integer ()
+  (erc-stamp-tests--insert-right
+   (lambda ()
+
+     (ert-info ("integer, normal")
+       (let ((erc-timestamp-use-align-to 1))
+         (let ((msg (erc-format-privmessage "bob" "msg one" nil t)))
+           (erc-display-message nil nil (current-buffer) msg)))
+       (goto-char (point-min))
+       ;; Space not added because included in format string.
+       (should (search-forward "msg one [" nil t))
+       ;; Field covers space between.
+       (should (eql ?e (char-before (field-beginning (point)))))
+       (should (eql ?\n (char-after (field-end (point))))))
+
+     (ert-info ("integer, overlong (hard wrap)")
+       (let ((erc-timestamp-use-align-to 1)
+             (erc-timestamp-right-column 20))
+         (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
+           (erc-display-message nil nil (current-buffer) msg)))
+       ;; No hard wrap
+       (should (search-forward "oooo [" nil t))
+       ;; Field starts at leading space.
+       (should (eql ?\s (char-after (field-beginning (point)))))
+       (should (eql ?\n (char-after (field-end (point)))))))))
+
+(ert-deftest erc-timestamp-use-align-to--margin ()
+  (erc-stamp-tests--insert-right
+   (lambda ()
+     (erc-stamp--display-margin-mode +1)
+
+     (ert-info ("margin, normal")
+       (let ((erc-timestamp-use-align-to 'margin))
+         (let ((msg (erc-format-privmessage "bob" "msg one" nil t)))
+           (put-text-property 0 (length msg) 'wrap-prefix 10 msg)
+           (erc-display-message nil nil (current-buffer) msg)))
+       (goto-char (point-min))
+       ;; Space not added (treated as opaque string).
+       (should (search-forward "msg one[" nil t))
+       ;; Field covers stamp alone
+       (should (eql ?e (char-before (field-beginning (point)))))
+       ;; Vanity props extended
+       (should (get-text-property (field-beginning (point)) 'wrap-prefix))
+       (should (get-text-property (1+ (field-beginning (point))) 'wrap-prefix))
+       (should (get-text-property (1- (field-end (point))) 'wrap-prefix))
+       (should (eql ?\n (char-after (field-end (point))))))
+
+     (ert-info ("margin, overlong (hard wrap)")
+       (let ((erc-timestamp-use-align-to 'margin)
+             (erc-timestamp-right-column 20))
+         (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t)))
+           (erc-display-message nil nil (current-buffer) msg)))
+       ;; No hard wrap
+       (should (search-forward "oooo[" nil t))
+       ;; Field starts at format string (right bracket)
+       (should (eql ?\[ (char-after (field-beginning (point)))))
        (should (eql ?\n (char-after (field-end (point)))))))))
 
 ;; This concerns a proposed partial reversal of the changes resulting