From f61a14c16154e0a170e0b9b58851279e282face9 Mon Sep 17 00:00:00 2001 From: dickmao Date: Sun, 20 Mar 2022 11:34:56 -0400 Subject: [PATCH] Rewrite hl-line-mode The fashion of dual global and minor modes, each managing a replica of state, has long been outmoded by globalized minor modes (nee easy-mmode-define-global-mode) around the turn of the century. * lisp/calendar/todo-mode.el (todo-toggle-item-highlighting, todo-hl-line-range, todo-modes-set-2): Adapt to new hl-line-highlight-hook. * lisp/hl-line.el (hl-line-overlay): Rename hl-line--overlay. (global-hl-line-overlay, global-hl-line-overlays, global-hl-line-sticky-flag, hl-line-overlay-buffer, hl-line-range-function): Obsolesce. (hl-line--overlay): Erstwhile hl-line-overlay. (hl-line, hl-line-face): Consolidate. (hl-line-sticky-flag): Say less (Gen Z Hospital). (hl-line-overlay-priority): Make this a custom. (hl-line-highlight-hook): Prefer hook over specialized hl-line-range-function. (hl-line-mode): Say less (Gen Z Hospital). (hl-line-make-overlay): Remove (hl-line-highlight, hl-line-unhighlight): Rewrite. (hl-line-maybe-unhighlight): Remove. (hl-line-turn-on): Necessary for globalized minor mode. (global-hl-line-mode, global-hl-line-highlight, global-hl-line-highlight-all, global-hl-line-unhighlight, global-hl-line-maybe-unhighlight, global-hl-line-unhighlight-all): Prefer globalized minor mode. (hl-line-move, hl-line-unload-function): Remove. * test/lisp/calendar/todo-mode-tests.el (todo-test-item-highlighting, todo-test-done-items-separator06-bol, todo-test-done-items-separator06-eol, todo-test-done-items-separator07): Adapt to consolidated face. --- lisp/calendar/todo-mode.el | 11 +- lisp/hl-line.el | 297 ++++++-------------------- test/lisp/calendar/todo-mode-tests.el | 10 +- test/lisp/hl-line-tests.el | 51 +++++ 4 files changed, 123 insertions(+), 246 deletions(-) create mode 100644 test/lisp/hl-line-tests.el diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 57fcd1b17e1..eed597a0337 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -1040,9 +1040,7 @@ todo-toggle-item-highlighting (eval-and-compile (require 'hl-line)) (when (memq major-mode '(todo-mode todo-archive-mode todo-filtered-items-mode)) - (if hl-line-mode - (hl-line-mode -1) - (hl-line-mode 1)))) + (hl-line-mode 'toggle))) (defvar todo--item-headers-hidden nil "Non-nil if item date-time headers in current buffer are hidden.") @@ -6676,9 +6674,8 @@ todo-modes-set-1 (defun todo-hl-line-range () "Make `todo-toggle-item-highlighting' highlight entire item." (save-excursion - (when (todo-item-end) - (cons (todo-item-start) - (todo-item-end))))) + (when (and (todo-item-end) hl-line--overlay) + (move-overlay hl-line--overlay (todo-item-start) (todo-item-end))))) (defun todo-modes-set-2 () "Make some settings that apply to multiple Todo modes." @@ -6686,7 +6683,7 @@ todo-modes-set-2 (setq buffer-read-only t) (setq-local todo--item-headers-hidden nil) (setq-local desktop-save-buffer 'todo-desktop-save-buffer) - (setq-local hl-line-range-function #'todo-hl-line-range)) + (add-hook 'hl-line-highlight-hook #'todo-hl-line-range nil t)) (defun todo-modes-set-3 () "Make some settings that apply to multiple Todo modes." diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 8e60ddf6b07..daa24c4fbf3 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -24,274 +24,103 @@ ;;; Commentary: -;; Provides a local minor mode (toggled by M-x hl-line-mode) and -;; a global minor mode (toggled by M-x global-hl-line-mode) to -;; highlight, on a suitable terminal, the line on which point is. The -;; global mode highlights the current line in the selected window only -;; (except when the minibuffer window is selected). This was -;; implemented to satisfy a request for a feature of Lesser Editors. -;; The local mode is sticky: it highlights the line about the buffer's -;; point even if the buffer's window is not selected. Caveat: the -;; buffer's point might be different from the point of a non-selected -;; window. Set the variable `hl-line-sticky-flag' to nil to make the -;; local mode behave like the global mode. - -;; You probably don't really want to use the global mode; if the -;; cursor is difficult to spot, try changing its color, relying on -;; `blink-cursor-mode' or both. The hookery used might affect -;; response noticeably on a slow machine. The local mode may be -;; useful in non-editing buffers such as Gnus or PCL-CVS though. - -;; An overlay is used. In the non-sticky cases, this overlay is -;; active only on the selected window. A hook is added to -;; `post-command-hook' to activate the overlay and move it to the line -;; about point. - -;; You could make variable `global-hl-line-mode' buffer-local and set -;; it to nil to avoid highlighting specific buffers, when the global -;; mode is used. - -;; By default the whole line is highlighted. The range of highlighting -;; can be changed by defining an appropriate function as the -;; buffer-local value of `hl-line-range-function'. - ;;; Code: -(defvar-local hl-line-overlay nil - "Overlay used by Hl-Line mode to highlight the current line.") +(make-obsolete-variable 'hl-line-overlay nil "29.1") +(make-obsolete-variable 'global-hl-line-overlay nil "29.1") +(make-obsolete-variable 'global-hl-line-overlays nil "29.1") +(make-obsolete-variable 'global-hl-line-sticky-flag nil "29.1") +(make-obsolete-variable 'hl-line-overlay-buffer nil "29.1") +(make-obsolete-variable 'hl-line-range-function nil "29.1") -(defvar-local global-hl-line-overlay nil - "Overlay used by Global-Hl-Line mode to highlight the current line.") +(defvar-local hl-line--overlay nil + "Keep state else scan entire buffer in `post-command-hook'.") -(defvar global-hl-line-overlays nil - "Overlays used by Global-Hl-Line mode in various buffers. -Global-Hl-Line keeps displaying one overlay in each buffer -when `global-hl-line-sticky-flag' is non-nil.") +;; 1. define-minor-mode creates buffer-local hl-line--overlay +;; 2. overlay wiped by kill-all-local-variables +;; 3. post-command-hook dupes overlay +;; Solution: prevent step 2. +(put 'hl-line--overlay 'permanent-local t) (defgroup hl-line nil "Highlight the current line." :version "21.1" :group 'convenience) -(defface hl-line - '((t :inherit highlight :extend t)) - "Default face for highlighting the current line in Hl-Line mode." +(defface hl-line-face '((t :inherit highlight :extend t)) + "Default face for highlighting the current line in hl-line-mode." :version "22.1" :group 'hl-line) -(defcustom hl-line-face 'hl-line - "Face with which to highlight the current line in Hl-Line mode." - :type 'face - :group 'hl-line - :set (lambda (symbol value) - (set symbol value) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (overlayp hl-line-overlay) - (overlay-put hl-line-overlay 'face hl-line-face)))) - (when (overlayp global-hl-line-overlay) - (overlay-put global-hl-line-overlay 'face hl-line-face)))) - (defcustom hl-line-sticky-flag t - "Non-nil means the HL-Line mode highlight appears in all windows. -Otherwise Hl-Line mode will highlight only in the selected -window. Setting this variable takes effect the next time you use -the command `hl-line-mode' to turn Hl-Line mode on. - -This variable has no effect in Global Highlight Line mode. -For that, use `global-hl-line-sticky-flag'." + "Non-nil to preserve highlighting overlay when focus leaves window." :type 'boolean :version "22.1" + :group 'hl-line + :set (lambda (symbol value) + (set-default symbol value) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight)))))))) + +(defcustom hl-line-overlay-priority -50 + "Priority used on the overlay used by hl-line." + :type 'integer + :version "22.1" :group 'hl-line) -(defcustom global-hl-line-sticky-flag nil - "Non-nil means the Global HL-Line mode highlight appears in all windows. -Otherwise Global Hl-Line mode will highlight only in the selected -window. Setting this variable takes effect the next time you use -the command `global-hl-line-mode' to turn Global Hl-Line mode on." - :type 'boolean - :version "24.1" +(defcustom hl-line-highlight-hook nil + "After hook for `hl-line-highlight'. +Currently used in calendar/todo-mode." + :type 'hook :group 'hl-line) -(defvar hl-line-range-function nil - "If non-nil, function to call to return highlight range. -The function of no args should return a cons cell; its car value -is the beginning position of highlight and its cdr value is the -end position of highlight in the buffer. -It should return nil if there's no region to be highlighted. - -This variable is expected to be made buffer-local by modes.") - -(defvar hl-line-overlay-buffer nil - "Most recently visited buffer in which Hl-Line mode is enabled.") - -(defvar hl-line-overlay-priority -50 - "Priority used on the overlay used by hl-line.") - ;;;###autoload (define-minor-mode hl-line-mode - "Toggle highlighting of the current line (Hl-Line mode). - -Hl-Line mode is a buffer-local minor mode. If -`hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the -line about the buffer's point in all windows. Caveat: the -buffer's point might be different from the point of a -non-selected window. Hl-Line mode uses the function -`hl-line-highlight' on `post-command-hook' in this case. - -When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the -line about point in the selected window only." + "Toggle highlighting of the current line." :group 'hl-line (if hl-line-mode (progn - ;; In case `kill-all-local-variables' is called. - (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (hl-line-highlight) - (setq hl-line-overlay-buffer (current-buffer)) + (add-hook 'change-major-mode-hook #'hl-line-unhighlight nil t) (add-hook 'post-command-hook #'hl-line-highlight nil t)) (remove-hook 'post-command-hook #'hl-line-highlight t) - (hl-line-unhighlight) - (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t))) - -(defun hl-line-make-overlay () - (let ((ol (make-overlay (point) (point)))) - (overlay-put ol 'priority hl-line-overlay-priority) ;(bug#16192) - (overlay-put ol 'face hl-line-face) - ol)) - -(defun hl-line-highlight () - "Activate the Hl-Line overlay on the current line." - (if hl-line-mode ; Might be changed outside the mode function. - (progn - (unless (overlayp hl-line-overlay) - (setq hl-line-overlay (hl-line-make-overlay))) ; To be moved. - (overlay-put hl-line-overlay - 'window (unless hl-line-sticky-flag (selected-window))) - (hl-line-move hl-line-overlay) - (hl-line-maybe-unhighlight)) - (hl-line-unhighlight))) + (remove-hook 'change-major-mode-hook #'hl-line-unhighlight t) + (let (hl-line-sticky-flag) + (hl-line-unhighlight)))) (defun hl-line-unhighlight () - "Deactivate the Hl-Line overlay on the current line." - (when (overlayp hl-line-overlay) - (delete-overlay hl-line-overlay) - (setq hl-line-overlay nil))) + (unless hl-line-sticky-flag + (when hl-line--overlay + (delete-overlay hl-line--overlay) + (setq hl-line--overlay nil)))) -(defun hl-line-maybe-unhighlight () - "Maybe deactivate the Hl-Line overlay on the current line. -Specifically, when `hl-line-sticky-flag' is nil deactivate all -such overlays in all buffers except the current one." - (let ((hlob hl-line-overlay-buffer) - (curbuf (current-buffer))) - (when (and (buffer-live-p hlob) - (not hl-line-sticky-flag) - (not (eq curbuf hlob)) - (not (minibufferp))) - (with-current-buffer hlob - (hl-line-unhighlight))) - (when (and (overlayp hl-line-overlay) - (eq (overlay-buffer hl-line-overlay) curbuf)) - (setq hl-line-overlay-buffer curbuf)))) +(defun hl-line-highlight () + (unless (minibufferp) + (unless hl-line--overlay + (setq hl-line--overlay + (let ((ol (make-overlay (point) (point)))) + (prog1 ol + (overlay-put ol 'priority hl-line-overlay-priority) + (overlay-put ol 'face 'hl-line-face))))) + (move-overlay hl-line--overlay + (line-beginning-position) + (line-beginning-position 2)) + (run-hooks 'hl-line-highlight-hook))) + +(defun hl-line-turn-on () + (unless (minibufferp) + (let (inhibit-quit) + (hl-line-mode 1)))) ;;;###autoload -(define-minor-mode global-hl-line-mode - "Toggle line highlighting in all buffers (Global Hl-Line mode). - -If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode -highlights the line about the current buffer's point in all live -windows. - -Global-Hl-Line mode uses the function `global-hl-line-highlight' -on `post-command-hook'." - :global t +(define-globalized-minor-mode global-hl-line-mode + hl-line-mode hl-line-turn-on :group 'hl-line - (if global-hl-line-mode - (progn - ;; In case `kill-all-local-variables' is called. - (add-hook 'change-major-mode-hook #'global-hl-line-unhighlight) - (global-hl-line-highlight-all) - (add-hook 'post-command-hook #'global-hl-line-highlight)) - (global-hl-line-unhighlight-all) - (remove-hook 'post-command-hook #'global-hl-line-highlight) - (remove-hook 'change-major-mode-hook #'global-hl-line-unhighlight))) - -(defun global-hl-line-highlight () - "Highlight the current line in the current window." - (when global-hl-line-mode ; Might be changed outside the mode function. - (unless (window-minibuffer-p) - (unless (overlayp global-hl-line-overlay) - (setq global-hl-line-overlay (hl-line-make-overlay))) ; To be moved. - (unless (member global-hl-line-overlay global-hl-line-overlays) - (push global-hl-line-overlay global-hl-line-overlays)) - (overlay-put global-hl-line-overlay 'window - (unless global-hl-line-sticky-flag - (selected-window))) - (hl-line-move global-hl-line-overlay) - (global-hl-line-maybe-unhighlight)))) - -(defun global-hl-line-highlight-all () - "Highlight the current line in all live windows." - (walk-windows (lambda (w) - (with-current-buffer (window-buffer w) - (global-hl-line-highlight))) - nil t)) - -(defun global-hl-line-unhighlight () - "Deactivate the Global-Hl-Line overlay on the current line." - (when (overlayp global-hl-line-overlay) - (delete-overlay global-hl-line-overlay) - (setq global-hl-line-overlay nil))) - -(defun global-hl-line-maybe-unhighlight () - "Maybe deactivate the Global-Hl-Line overlay on the current line. -Specifically, when `global-hl-line-sticky-flag' is nil deactivate -all such overlays in all buffers except the current one." - (mapc (lambda (ov) - (let ((ovb (overlay-buffer ov))) - (when (and (not global-hl-line-sticky-flag) - (bufferp ovb) - (not (eq ovb (current-buffer))) - (not (minibufferp))) - (with-current-buffer ovb - (global-hl-line-unhighlight))))) - global-hl-line-overlays)) - -(defun global-hl-line-unhighlight-all () - "Deactivate all Global-Hl-Line overlays." - (mapc (lambda (ov) - (let ((ovb (overlay-buffer ov))) - (when (bufferp ovb) - (with-current-buffer ovb - (global-hl-line-unhighlight))))) - global-hl-line-overlays) - (setq global-hl-line-overlays nil)) - -(defun hl-line-move (overlay) - "Move the Hl-Line overlay. -If `hl-line-range-function' is non-nil, move the OVERLAY to the position -where the function returns. If `hl-line-range-function' is nil, fill -the line including the point by OVERLAY." - (let (tmp b e) - (if hl-line-range-function - (setq tmp (funcall hl-line-range-function) - b (car tmp) - e (cdr tmp)) - (setq tmp t - b (line-beginning-position) - e (line-beginning-position 2))) - (if tmp - (move-overlay overlay b e) - (move-overlay overlay 1 1)))) - -(defun hl-line-unload-function () - "Unload the Hl-Line library." - (global-hl-line-mode -1) - (save-current-buffer - (dolist (buffer (buffer-list)) - (set-buffer buffer) - (when hl-line-mode (hl-line-mode -1)))) - ;; continue standard unloading - nil) + :version "29.1") (provide 'hl-line) diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 0102b62c10f..8715a32b883 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -130,8 +130,8 @@ todo-test-item-highlighting (todo-toggle-item-highlighting) (let ((end (1- (todo-item-end))) (beg (todo-item-start))) - (should (eq (get-char-property beg 'face) 'hl-line)) - (should (eq (get-char-property end 'face) 'hl-line)) + (should (eq (get-char-property beg 'face) 'hl-line-face)) + (should (eq (get-char-property end 'face) 'hl-line-face)) (should (> (count-lines beg end) 1)) (should (eq (next-single-char-property-change beg 'face) (1+ end)))) (todo-toggle-item-highlighting))) ; Turn off highlighting (for test rerun). @@ -736,7 +736,7 @@ todo-test-done-items-separator06-bol (todo-test--done-items-separator) (call-interactively #'todo-toggle-item-highlighting) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator06-eol () ; bug#32343 "Test enabling item highlighting at EOL of done items separator. @@ -746,7 +746,7 @@ todo-test-done-items-separator06-eol (todo-toggle-item-highlighting) (forward-line -1) (ert-simulate-command '(todo-previous-item)) - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-done-items-separator07 () ; bug#32343 "Test item highlighting when crossing done items separator. @@ -758,7 +758,7 @@ todo-test-done-items-separator07 (todo-next-item) ; Now on empty line above separator. (forward-line) ; Now on separator. (ert-simulate-command '(forward-line)) ; Now on first done item. - (should (eq 'hl-line (get-char-property (point) 'face))))) + (should (eq 'hl-line-face (get-char-property (point) 'face))))) (ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437 "Test the value of todo-current-todo-file in todo-edit-mode." diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el new file mode 100644 index 00000000000..422d4ddae7d --- /dev/null +++ b/test/lisp/hl-line-tests.el @@ -0,0 +1,51 @@ +;;; hl-line-tests.el --- Test suite for hl-line. -*- lexical-binding: t -*- + +;; Copyright (C) 2022 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 . + +;;; Code: +(require 'ert) +(require 'hl-line) + +(ert-deftest hl-line-sticky () + (should hl-line-sticky-flag) + (with-temp-buffer + (let ((from-buffer (current-buffer))) + (hl-line-mode 1) + (save-excursion + (insert "foo")) + (hl-line-highlight) + (should (cl-some (apply-partially #'eq hl-line--overlay) + (overlays-at (point)))) + (switch-to-buffer (get-buffer-create "*scratch*")) + (hl-line-mode 1) + (save-excursion + (insert "bar")) + (hl-line-highlight) + (should (cl-some (apply-partially #'eq hl-line--overlay) + (overlays-at (point)))) + (should (buffer-local-value 'hl-line--overlay from-buffer)) + (should-not (eq (buffer-local-value 'hl-line--overlay from-buffer) + hl-line--overlay)) + (customize-set-variable 'hl-line-sticky-flag nil) + (should hl-line--overlay) + (should (buffer-live-p from-buffer)) + (should-not (buffer-local-value 'hl-line--overlay from-buffer))))) + +(provide 'hl-line-tests) + +;;; hl-line-tests.el ends here -- 2.26.2