>From 8ff3d6905355e41bd91fd8e24577b68e762cfb0a Mon Sep 17 00:00:00 2001
From: "F. Jason Park" <jp@neverwas.me>
Date: Fri, 13 Jan 2023 00:00:56 -0800
Subject: [PATCH 8/8] [5.6] Add erc-fill style based on visual-line-mode

* lisp/erc/erc-common.el (erc--features-to-modules): Add mapping for
local module `fill-wrap'.
* lisp/erc/erc-fill.el (erc-fill-function): Add new value,
`erc-fill-wrap'.
(erc-fill-static-center): Extend meaning of option to also affect
`erc-wrap-mode'.
(erc-fill-wrap-mode, erc-fill--wrap-prefix, erc-fill--wrap-value,
erc-fill--wrap-movement): New minor mode and variables to support it.
(erc-fill-wrap-movement): New option to control how where
`visual-line-mode' keys are active.
(erc-fill--wrap-kill-line, erc-fill--wrap-beginning-of-line,
erc-fill--wrap-end-of-line): New movement commands.
(erc-fill-wrap-cycle-visual-movement): New command to cycle local
value of `erc-fill-wrap-movement'.
(erc-fill-wrap-mode-map): New map based on `visual-line-mode-map'.
(erc-fill-wrap): New function implementing
`erc-fill-function' (behavioral) interface.
(erc-fill-wrap-nudge, erc-fill--wrap-nudge): New command and helper
for growing and shrinking visual fill prefix.
* test/lisp/erc/erc-fill-tests.el: New file.
---
 lisp/erc/erc-common.el          |   1 +
 lisp/erc/erc-fill.el            | 273 +++++++++++++++++++++++++++++++-
 test/lisp/erc/erc-fill-tests.el | 172 ++++++++++++++++++++
 3 files changed, 441 insertions(+), 5 deletions(-)
 create mode 100644 test/lisp/erc/erc-fill-tests.el

diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el
index 994555acecf..aae8280baa9 100644
--- a/lisp/erc/erc-common.el
+++ b/lisp/erc/erc-common.el
@@ -95,6 +95,7 @@ erc--features-to-modules
     (erc-join autojoin)
     (erc-page page ctcp-page)
     (erc-sound sound ctcp-sound)
+    (erc-fill fill-wrap)
     (erc-stamp stamp timestamp)
     (erc-services services nickserv))
   "Migration alist mapping a library feature to module names.
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index caf401bf222..ecd721f2f03 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -28,6 +28,9 @@
 ;; `erc-fill-mode' to switch it on.  Customize `erc-fill-function' to
 ;; change the style.
 
+;; TODO: redo `erc-fill-wrap-nudge' using transient after ERC drops
+;; support for Emacs 27.
+
 ;;; Code:
 
 (require 'erc)
@@ -79,16 +82,29 @@ erc-fill-function
 These two styles are implemented using `erc-fill-variable' and
 `erc-fill-static'.  You can, of course, define your own filling
 function.  Narrowing to the region in question is in effect while your
-function is called."
+function is called.
+
+A third style resembles static filling but \"wraps\" instead of
+fills, thanks to `visual-line-mode' mode, which ERC automatically
+enables when this option is `erc-fill-wrap' or when
+`erc-fill-wrap-mode' is active.  Set `erc-fill-static-center' to
+your preferred initial \"prefix\" width.  For adjusting the width
+during a session, see the command `erc-fill-wrap-nudge'."
   :type '(choice (const :tag "Variable Filling" erc-fill-variable)
                  (const :tag "Static Filling" erc-fill-static)
+                 (const :tag "Dynamic word-wrap" erc-fill-wrap)
                  function))
 
 (defcustom erc-fill-static-center 27
-  "Column around which all statically filled messages will be centered.
-This column denotes the point where the ` ' character between
-<nickname> and the entered text will be put, thus aligning nick
-names right and text left."
+  "Number of columns to \"outdent\" the first line of a message.
+During early message handing, ERC prepends a span of
+non-whitespace characters to every message, such as a bracketed
+\"<nickname>\" or an `erc-notice-prefix'.  The
+`erc-fill-function' variants `erc-fill-static' and
+`erc-fill-wrap' look to this option to determine the amount of
+padding to apply to that portion until the filled (or wrapped)
+message content aligns with the indicated column.  See also
+https://en.wikipedia.org/wiki/Hanging_indent."
   :type 'integer)
 
 (defcustom erc-fill-variable-maximum-indentation 17
@@ -155,6 +171,253 @@ erc-fill-variable
           (erc-fill-regarding-timestamp))))
     (erc-restore-text-properties)))
 
+(defvar-local erc-fill--wrap-prefix nil)
+(defvar-local erc-fill--wrap-value nil)
+(defvar-local erc-fill--wrap-visual-keys nil)
+
+(defcustom erc-fill-wrap-use-pixels t
+  "Whether to calculate padding in pixels when possible.
+A value of nil means ERC should use columns, which may happen
+regardless, depending on the Emacs version.  This option only
+matters when `erc-fill-wrap-mode' is enabled."
+  :package-version '(ERC . "5.5") ; FIXME sync on release
+  :type 'boolean)
+
+(defcustom erc-fill-wrap-visual-keys 'non-input
+  "Whether to retain keys defined by `visual-line-mode'.
+A value of t tells ERC to use movement commands defined by
+`visual-line-mode' everywhere in an ERC buffer along with visual
+editing commands in the input area.  A value of nil means to
+never do so.  A value of `non-input' tells ERC to act like the
+value is nil in the input area and t elsewhere.  This option only
+plays a role when `erc-fill-wrap-mode' is enabled."
+  :package-version '(ERC . "5.5") ; FIXME sync on release
+  :type '(choice (const nil) (const t) (const non-input)))
+
+(defun erc-fill--wrap-move (normal-cmd visual-cmd arg)
+  (funcall
+   (pcase erc-fill--wrap-visual-keys
+     ('non-input (if (>= (point) erc-input-marker) normal-cmd visual-cmd))
+     ('t visual-cmd)
+     (_ normal-cmd))
+   arg))
+
+(defun erc-fill--wrap-kill-line (arg)
+  "Defer to `kill-line' or `kill-visual-line'."
+  (interactive "P")
+  ;; ERC buffers are read-only outside of the input area, but we run
+  ;; `kill-line' anyway so that users can see the error.
+  (erc-fill--wrap-move #'kill-line #'kill-visual-line arg))
+
+(defun erc-fill--wrap-beginning-of-line (arg)
+  "Defer to `move-beginning-of-line' or `beginning-of-visual-line'."
+  (interactive "^p")
+  (let ((inhibit-field-text-motion t))
+    (erc-fill--wrap-move #'move-beginning-of-line
+                         #'beginning-of-visual-line arg))
+  (when (get-text-property (point) 'erc-prompt)
+    (goto-char erc-input-marker)))
+
+(defun erc-fill--wrap-end-of-line (arg)
+  "Defer to `move-end-of-line' or `end-of-visual-line'."
+  (interactive "^p")
+  (erc-fill--wrap-move #'move-end-of-line #'end-of-visual-line arg))
+
+(defun erc-fill-wrap-cycle-visual-movement (arg)
+  "Cycle through `erc-fill-wrap-visual-keys' styles ARG times.
+Go from nil to t to `non-input' and back around, but set internal
+state instead of mutating `erc-fill-wrap-visual-keys'.  When ARG
+is 0, reset to value of `erc-fill-wrap-visual-keys'."
+  (interactive "^p")
+  (when (zerop arg)
+    (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys))
+  (while (not (zerop arg))
+    (cl-incf arg (- (abs arg)))
+    (setq erc-fill--wrap-visual-keys (pcase erc-fill--wrap-visual-keys
+                                       ('nil t)
+                                       ('t 'non-input)
+                                       ('non-input nil))))
+  (message "erc-fill-wrap-movement: %S" erc-fill--wrap-visual-keys))
+
+(defvar-keymap erc-fill-wrap-mode-map ; Compat 29
+  :doc "Keymap for ERC's `fill-wrap' module."
+  :parent visual-line-mode-map
+  "<remap> <kill-line>" #'erc-fill--wrap-kill-line
+  "<remap> <move-end-of-line>" #'erc-fill--wrap-end-of-line
+  "<remap> <move-beginning-of-line>" #'erc-fill--wrap-beginning-of-line
+  "C-c a" #'erc-fill-wrap-cycle-visual-movement
+  ;; Not sure if this is problematic because `erc-bol' takes no args.
+  "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line)
+
+(defvar erc-match-mode)
+(defvar erc-match--hide-fools-offset-bounds)
+
+(define-erc-module fill-wrap nil
+  "Fill style leveraging `visual-line-mode'.
+This local module depends on the global `fill' module.  To use
+it, either include `fill-wrap' in `erc-modules' or set
+`erc-fill-function' to `erc-fill-wrap'.  You can also manually
+invoke one of the minor-mode toggles.  When the option
+`erc-insert-timestamp-function' is `erc-insert-timestamp-right'
+or `erc-insert-timestamp-left-and-right', it shows timestamps in
+the right margin."
+  ((let (msg)
+     (unless erc-fill-mode
+       (unless (memq 'fill erc-modules)
+         (setq msg
+               (concat "WARNING: enabling default global module `fill' needed "
+                       " by local module `fill-wrap'.  This will impact all"
+                       " ERC sessions.  Add `fill' to `erc-modules' to avoid "
+                       " this warning. See Info:\"(erc) Modules\" for more.")))
+       (erc-fill-mode +1))
+     ;; Set local value of user option (can we avoid this somehow?)
+     (unless (eq erc-fill-function #'erc-fill-wrap)
+       (setq-local erc-fill-function #'erc-fill-wrap))
+     (when-let* ((vars (or erc--server-reconnecting erc--target-priors))
+                 ((alist-get 'erc-fill-wrap-mode vars)))
+       (setq erc-fill--wrap-visual-keys (alist-get 'erc-fill--wrap-visual-keys
+                                                   vars)
+             erc-fill--wrap-prefix (alist-get 'erc-fill--wrap-prefix vars)
+             erc-fill--wrap-value (alist-get 'erc-fill--wrap-value vars)))
+     (when (or erc-stamp-mode (memq 'stamp erc-modules))
+       (erc-stamp--display-margin-mode +1))
+     (when (or (bound-and-true-p erc-match-mode) (memq 'match erc-modules))
+       (require 'erc-match)
+       (setq erc-match--hide-fools-offset-bounds t))
+     (setq erc-fill--wrap-value
+           (or erc-fill--wrap-value erc-fill-static-center)
+           ;;
+           erc-fill--wrap-prefix
+           (or erc-fill--wrap-prefix
+               (list 'space :width erc-fill--wrap-value)))
+     (visual-line-mode +1)
+     (unless (local-variable-p 'erc-fill--wrap-visual-keys)
+       (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys))
+     (when msg
+       (erc-display-error-notice nil msg))))
+  ((when erc-stamp--display-margin-mode
+     (erc-stamp--display-margin-mode -1))
+   (kill-local-variable 'erc-button--add-nickname-face-function)
+   (kill-local-variable 'erc-fill--wrap-prefix)
+   (kill-local-variable 'erc-fill--wrap-value)
+   (kill-local-variable 'erc-fill-function)
+   (kill-local-variable 'erc-fill--wrap-visual-keys)
+   (visual-line-mode -1))
+  'local)
+
+(defvar-local erc-fill--wrap-length-function nil
+  "Function to determine length of overhanging characters.
+It should return an EXPR as defined by the info node `(elisp)
+Pixel Specification'.  This value should represent the width of
+the overhang with all faces applied, including any enclosing
+brackets (which are not normally fontified) and a trailing space.
+It can also return nil to tell ERC to fall back to the default
+behavior of taking the length from the first \"word\".  This
+variable can be converted to a public one if needed by third
+parties.")
+
+(defun erc-fill-wrap ()
+  "Use text props to mimic the effect of `erc-fill-static'.
+See `erc-fill-wrap-mode' for details."
+  (unless erc-fill-wrap-mode
+    (erc-fill-wrap-mode +1))
+  (save-excursion
+    (goto-char (point-min))
+    (let* ((len (or (and erc-fill--wrap-length-function
+                         (funcall erc-fill--wrap-length-function))
+                    (progn
+                      (skip-syntax-forward "^-")
+                      (forward-char)
+                      (if (and erc-fill-wrap-use-pixels
+                               (fboundp 'buffer-text-pixel-size))
+                          (save-restriction
+                            (narrow-to-region (point-min) (point))
+                            (list (car (buffer-text-pixel-size))))
+                        (- (point) (point-min)))))))
+      ;; Leaving out the final newline doesn't seem to affect anything.
+      (erc-put-text-properties (point-min) (point-max)
+                               '(line-prefix wrap-prefix) nil
+                               `((space :width (- ,erc-fill--wrap-value ,len))
+                                 ,erc-fill--wrap-prefix)))))
+
+;; This is an experimental helper for third-party modules.  You could,
+;; for example, use this to automatically resize the prefix to a
+;; fraction of the window's width on some event change.
+
+(defun erc-fill--wrap-fix (&optional value)
+  "Re-wrap from `point-min' to `point-max'.
+Reset prefix to VALUE, when given."
+  (save-excursion
+    (when value
+      (setq erc-fill--wrap-value value
+            erc-fill--wrap-prefix (list 'space :width value)))
+    (let ((inhibit-field-text-motion t)
+          (inhibit-read-only t))
+      (goto-char (point-min))
+      (while (and (zerop (forward-line))
+                  (< (point) (min (point-max) erc-insert-marker)))
+        (save-restriction
+          (narrow-to-region (line-beginning-position) (line-end-position))
+          (erc-fill-wrap))))))
+
+(defun erc-fill--wrap-nudge (arg)
+  (save-excursion
+    (save-restriction
+      (widen)
+      (let ((inhibit-field-text-motion t)
+            (inhibit-read-only t) ; necessary?
+            (p (goto-char (point-min))))
+        (when (zerop arg)
+          (setq arg (- erc-fill-static-center erc-fill--wrap-value)))
+        (cl-incf (caddr erc-fill--wrap-prefix) arg)
+        (cl-incf erc-fill--wrap-value arg)
+        (while (setq p (next-single-property-change p 'line-prefix))
+          (when-let ((v (get-text-property p 'line-prefix)))
+            (cl-incf (nth 1 (nth 2 v)) arg) ; (space :width (- *this* len))
+            (when-let
+                ((e (text-property-not-all p (point-max) 'line-prefix v)))
+              (goto-char e)))))))
+  arg)
+
+(defun erc-fill-wrap-nudge (arg)
+  "Adjust `erc-fill-wrap' by ARG columns.
+Offer to repeat command in a manner similar to
+`text-scale-adjust'.  Note that misalignment may occur when
+messages contain decorations applied by third-party modules.
+See `erc-fill--wrap-fix' for a workaround."
+  (interactive "p")
+  (unless erc-fill--wrap-value
+    (cl-assert (not erc-fill-wrap-mode))
+    (user-error "Minor mode `erc-fill-wrap-mode' disabled"))
+  (let ((total (erc-fill--wrap-nudge arg))
+        (start (window-start))
+        (marker (set-marker (make-marker) (point))))
+    (when (zerop arg)
+      (setq arg 1))
+    (set-transient-map
+     (let ((map (make-sparse-keymap)))
+       (dolist (key '(?+ ?= ?- ?0))
+         (let ((a (pcase key
+                    (?0 0)
+                    (?- (- (abs arg)))
+                    (_ (abs arg)))))
+           (define-key map (vector (list key))
+                       (lambda ()
+                         (interactive)
+                         (cl-incf total (erc-fill--wrap-nudge a))
+                         (set-window-start (selected-window) start)
+                         (goto-char marker)))))
+       map)
+     t
+     (lambda ()
+       (set-marker marker nil)
+       (message "Fill prefix: %d (%+d col%s)"
+                erc-fill--wrap-value total (if (> (abs total) 1) "s" "")))
+     "Use %k for further adjustment"
+     1)
+    (goto-char marker)
+    (set-window-start (selected-window) start)))
+
 (defun erc-fill-regarding-timestamp ()
   "Fills a text such that messages start at column `erc-fill-static-center'."
   (fill-region (point-min) (point-max) t t)
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
new file mode 100644
index 00000000000..77d553bc3a2
--- /dev/null
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -0,0 +1,172 @@
+;;; erc-fill-tests.el --- Tests for erc-fill  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+(require 'ert-x)
+(require 'erc-fill)
+
+(defun erc-fill-tests--wrap-populate (test)
+  (let ((proc (start-process "sleep" (current-buffer) "sleep" "1"))
+        (id (erc-networks--id-create 'foonet))
+        (erc-insert-modify-hook '(erc-fill erc-add-timestamp))
+        (erc-server-users (make-hash-table :test 'equal))
+        (erc-fill-function 'erc-fill-wrap)
+        (erc-modules '(fill stamp))
+        (msg "Hello World")
+        erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
+    (when (bound-and-true-p erc-button-mode)
+      (push 'erc-button-add-buttons erc-insert-modify-hook))
+    (erc-mode)
+    (setq erc-server-process proc erc-networks--id id)
+    (set-process-query-on-exit-flag erc-server-process nil)
+
+    (with-current-buffer (get-buffer-create "#chan")
+      (erc-mode)
+      (erc-munge-invisibility-spec)
+      (setq erc-server-process proc
+            erc-networks--id id
+            erc-channel-users (make-hash-table :test 'equal)
+            erc--target (erc--target-from-string "#chan")
+            erc-default-recipients (list "#chan"))
+      (erc--initialize-markers (point) nil)
+
+      (erc-update-channel-member
+       "#chan" "alice" "alice" t nil nil nil nil nil "fake" "~u" nil nil t)
+
+      (erc-update-channel-member
+       "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t)
+      (setq msg "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.")
+
+      (erc-display-message nil 'notice (current-buffer) msg)
+      (setq msg "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.")
+
+      (erc-display-message
+       nil nil (current-buffer)
+       (erc-format-privmessage "alice" msg nil t))
+      (setq msg "alice: Either your unparagoned mistress is dead,\
+ or she's outprized by a trifle.")
+
+      (erc-display-message
+       nil nil (current-buffer)
+       (erc-format-privmessage "bob" msg nil t))
+
+      (funcall test)
+      (when noninteractive
+        (kill-buffer)))))
+
+(ert-deftest erc-fill-wrap--monospace ()
+  :tags '(:unstable)
+
+  (erc-fill-tests--wrap-populate
+
+   (lambda ()
+
+     ;; Prefix props are applied properly and faces are accounted
+     ;; for when determining widths.
+     (goto-char (point-min))
+     (should (search-forward "<a" nil t))
+     (should (get-text-property (pos-bol) 'line-prefix))
+     (should (get-text-property (pos-eol) 'line-prefix))
+     (should (equal (get-text-property (pos-bol) 'wrap-prefix)
+                    '(space :width 27)))
+     (should (equal (get-text-property (pos-eol) 'wrap-prefix)
+                    '(space :width 27)))
+     ;; The last elt in the `:width' value is a singleton (NUM) when
+     ;; figuring pixels.  Otherwise, it's just NUM. See EXPR in the
+     ;; prod rules table under (info "(elisp) Pixel Specification").
+     (should (pcase (get-text-property (point) 'line-prefix)
+               ((and (guard (fboundp 'string-pixel-width))
+                     `(space :width (- 27 (,w))))
+                (= w (string-pixel-width "<alice> ")))
+               (`(space :width (- 27 ,w))
+                (= w (length "<alice> ")))))
+
+     (erc-fill--wrap-nudge 2)
+
+     (should (search-forward "<b" nil t))
+     (should (get-text-property (pos-bol) 'line-prefix))
+     (should (get-text-property (pos-eol) 'line-prefix))
+     (should (equal (get-text-property (pos-bol) 'wrap-prefix)
+                    '(space :width 29)))
+     (should (equal (get-text-property (pos-eol) 'wrap-prefix)
+                    '(space :width 29)))
+     (should (pcase (get-text-property (point) 'line-prefix)
+               ((and (guard (fboundp 'string-pixel-width))
+                     `(space :width (- 29 (,w))))
+                (= w (string-pixel-width "<bob> ")))
+               (`(space :width (- 29 ,w))
+                (= w (length "<bob> "))))))))
+
+(ert-deftest erc-fill-wrap--variable-pitch ()
+  :tags '(:unstable)
+  (unless (and (fboundp 'string-pixel-width)
+               (not noninteractive)
+               (display-graphic-p))
+    (ert-skip "Test needs interactive graphical Emacs"))
+
+  (with-selected-frame (make-frame '((name . "other")))
+    (set-face-attribute 'default (selected-frame)
+                        :family "Sans Serif"
+                        :foundry 'unspecified
+                        :font 'unspecified)
+
+    (erc-fill-tests--wrap-populate
+
+     (lambda ()
+
+       (goto-char (point-min))
+       (should (search-forward "<a" nil t))
+       (should (get-text-property (pos-bol) 'line-prefix))
+       (should (get-text-property (pos-eol) 'line-prefix))
+       (should (equal (get-text-property (pos-bol) 'wrap-prefix)
+                      '(space :width 27)))
+       (should (equal (get-text-property (pos-eol) 'wrap-prefix)
+                      '(space :width 27)))
+       (should (pcase (get-text-property (point) 'line-prefix)
+                 (`(space :width (- 27 (,w)))
+                  (> w (string-pixel-width "<alice> ")))))
+
+       (erc-fill--wrap-nudge 2)
+
+       (should (search-forward "<b" nil t))
+       (should (get-text-property (pos-bol) 'line-prefix))
+       (should (get-text-property (pos-eol) 'line-prefix))
+       (should (equal (get-text-property (pos-bol) 'wrap-prefix)
+                      '(space :width 29)))
+       (should (equal (get-text-property (pos-eol) 'wrap-prefix)
+                      '(space :width 29)))
+       (should (pcase (get-text-property (point) 'line-prefix)
+                 (`(space :width (- 29 (,w)))
+                  (> w (string-pixel-width "<bob> ")))))
+
+       ;; FIXME figure out how to get rid of this "void variable
+       ;; `erc--results-ewoc'" error, which seems related to operating
+       ;; in this second frame.
+       ;;
+       ;; As a kludge, checking if point made it to the prompt can
+       ;; serve as visual confirmation that the test passed.
+       (goto-char (point-max))))))
+
+;;; erc-fill-tests.el ends here
-- 
2.39.1