Version 1.3.1

[gnu-emacs-elpa] / beacon.el

diff --git a/beacon.el b/beacon.el
index ffdbcbc3b63821ea841747b9edafeff02b2c6575..9a3edacb1404affab6eefabca27d3d2cd9c032a6 100644 (file)
--- a/beacon.el
+++ b/beacon.el
@@ -5,8 +5,8 @@
 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
 ;; URL: https://github.com/Malabarba/beacon
 ;; Keywords: convenience
 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
 ;; URL: https://github.com/Malabarba/beacon
 ;; Keywords: convenience

-;; Version: 0.3
-;; Package-Requires: ((seq "1.9"))
+;; Version: 1.3.1
+;; Package-Requires: ((seq "2.14"))

 
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
 
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by


@@ -38,6 +38,24 @@
 ;;; Code:
 
 (require 'seq)
 ;;; Code:
 
 (require 'seq)

+(require 'faces)
+(unless (fboundp 'seq-mapn)
+  ;; This is for people who are on outdated Emacs snapshots. Will be
+  ;; deleted in a couple of weeks.
+  (defun seq-mapn (function sequence &rest sequences)
+    "Like `seq-map' but FUNCTION is mapped over all SEQUENCES.
+The arity of FUNCTION must match the number of SEQUENCES, and the
+mapping stops on the shortest sequence.
+Return a list of the results.
+
+\(fn FUNCTION SEQUENCES...)"
+    (let ((result nil)
+          (sequences (seq-map (lambda (s) (seq-into s 'list))
+                            (cons sequence sequences))))
+      (while (not (memq nil sequences))
+        (push (apply function (seq-map #'car sequences)) result)
+        (setq sequences (seq-map #'cdr sequences)))
+      (nreverse result))))

 
 (defgroup beacon nil
   "Customization group for beacon."
 
 (defgroup beacon nil
   "Customization group for beacon."


@@ -53,13 +71,20 @@ Otherwise this should be a number, and `beacon' will push the
 mark whenever point moves more than that many lines."
   :type '(choice integer (const nil)))
 
 mark whenever point moves more than that many lines."
   :type '(choice integer (const nil)))
 

-(defcustom beacon-blink-when-point-moves nil
-  "Should the beacon blink when moving a long distance?
-If nil, don't blink due to plain movement.
+(defcustom beacon-blink-when-point-moves-vertically nil
+  "Should the beacon blink when moving a long distance vertically?
+If nil, don't blink due to vertical movement.

 If non-nil, this should be an integer, which is the minimum
 movement distance (in lines) that triggers a beacon blink."
   :type '(choice integer (const nil)))
 
 If non-nil, this should be an integer, which is the minimum
 movement distance (in lines) that triggers a beacon blink."
   :type '(choice integer (const nil)))
 

+(defcustom beacon-blink-when-point-moves-horizontally nil
+  "Should the beacon blink when moving a long distance horizontally?
+If nil, don't blink due to horizontal movement.
+If non-nil, this should be an integer, which is the minimum
+movement distance (in columns) that triggers a beacon blink."
+  :type '(choice integer (const nil)))
+

 (defcustom beacon-blink-when-buffer-changes t
   "Should the beacon blink when changing buffer?"
   :type 'boolean)
 (defcustom beacon-blink-when-buffer-changes t
   "Should the beacon blink when changing buffer?"
   :type 'boolean)


@@ -124,20 +149,27 @@ For instance, if you want to disable beacon on buffers where
 
 (add-hook 'beacon-dont-blink-predicates #'window-minibuffer-p)
 
 
 (add-hook 'beacon-dont-blink-predicates #'window-minibuffer-p)
 

-(defcustom beacon-dont-blink-major-modes '(magit-status-mode magit-popup-mode)
+(defcustom beacon-dont-blink-major-modes '(t magit-status-mode magit-popup-mode
+                                       inf-ruby-mode
+                                       gnus-summary-mode gnus-group-mode)

   "A list of major-modes where the beacon won't blink.
 Whenever the current buffer satisfies `derived-mode-p' for
 one of the major-modes on this list, the beacon will not
 blink."
   :type '(repeat symbol))
 
   "A list of major-modes where the beacon won't blink.
 Whenever the current buffer satisfies `derived-mode-p' for
 one of the major-modes on this list, the beacon will not
 blink."
   :type '(repeat symbol))
 

-(defcustom beacon-dont-blink-commands '(recenter-top-bottom)
+(defcustom beacon-dont-blink-commands '(next-line previous-line
+                                            forward-line)

   "A list of commands that should not make the beacon blink.
 Use this for commands that scroll the window in very
 predictable ways, when the blink would be more distracting
 than helpful.."
   :type '(repeat symbol))
 
   "A list of commands that should not make the beacon blink.
 Use this for commands that scroll the window in very
 predictable ways, when the blink would be more distracting
 than helpful.."
   :type '(repeat symbol))
 

+(defcustom beacon-before-blink-hook nil
+  "Hook run immediately before blinking the beacon."
+  :type 'hook)
+

 \f
 ;;; Internal variables
 (defvar beacon--window-scrolled nil)
 \f
 ;;; Internal variables
 (defvar beacon--window-scrolled nil)


@@ -204,16 +236,18 @@ COLORS applied to each one."
 
 (defun beacon--ov-at-point ()
   (car (or (seq-filter (lambda (o) (overlay-get o 'beacon))
 
 (defun beacon--ov-at-point ()
   (car (or (seq-filter (lambda (o) (overlay-get o 'beacon))

-                     (overlays-in (point) (point)))
+                       (overlays-in (point) (point)))

            (seq-filter (lambda (o) (overlay-get o 'beacon))
            (seq-filter (lambda (o) (overlay-get o 'beacon))

-                     (overlays-at (point))))))
+                       (overlays-at (point))))))

 
 

-(defun beacon--vanish ()
+(defun beacon--vanish (&rest _)

   "Turn off the beacon."
   "Turn off the beacon."

-  (when (timerp beacon--timer)
-    (cancel-timer beacon--timer))
-  (mapc #'delete-overlay beacon--ovs)
-  (setq beacon--ovs nil))
+  (unless (string-match "\\` \\*\\(temp-buffer\\|Echo Area.*\\)\\*"
+                        (buffer-name))
+    (when (timerp beacon--timer)
+      (cancel-timer beacon--timer))
+    (mapc #'delete-overlay beacon--ovs)
+    (setq beacon--ovs nil)))

 
 \f
 ;;; Colors
 
 \f
 ;;; Colors


@@ -228,17 +262,25 @@ Only returns `beacon-size' elements."
 
 (defun beacon--color-range ()
   "Return a list of background colors for the beacon."
 
 (defun beacon--color-range ()
   "Return a list of background colors for the beacon."

-  (let* ((default-bg (face-attribute 'default :background))
-         (bg (color-values (if (string-match "\\`unspecified-" default-bg)
+  (let* ((default-bg (or (save-excursion
+                           (unless (eobp)
+                             (forward-line 1)
+                             (unless (or (bobp) (not (bolp)))
+                               (forward-char -1)))
+                           (background-color-at-point))
+                         (face-background 'default)))
+         (bg (color-values (if (or (not (stringp default-bg))
+                                   (string-match "\\`unspecified-" default-bg))

                                (face-attribute 'beacon-fallback-background :background)
                              default-bg)))
          (fg (cond
               ((stringp beacon-color) (color-values beacon-color))
                                (face-attribute 'beacon-fallback-background :background)
                              default-bg)))
          (fg (cond
               ((stringp beacon-color) (color-values beacon-color))

-              ((< (color-distance "black" bg)
-                  (color-distance "white" bg))
+              ((and (stringp bg)
+                    (< (color-distance "black" bg)
+                       (color-distance "white" bg)))

                (make-list 3 (* beacon-color 65535)))
               (t (make-list 3 (* (- 1 beacon-color) 65535))))))
                (make-list 3 (* beacon-color 65535)))
               (t (make-list 3 (* (- 1 beacon-color) 65535))))))

-    (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b))
+    (apply #'seq-mapn (lambda (r g b) (format "#%04x%04x%04x" r g b))

            (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n))))
                    [0 1 2]))))
 
            (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n))))
                    [0 1 2]))))
 


@@ -265,8 +307,10 @@ Only returns `beacon-size' elements."
     (o
      (delete-overlay o)
      (save-excursion
     (o
      (delete-overlay o)
      (save-excursion

-       (while (progn (forward-char 1)
-                     (setq o (beacon--ov-at-point)))
+       (while (and (condition-case nil
+                       (progn (forward-char 1) t)
+                     (end-of-buffer nil))
+                   (setq o (beacon--ov-at-point)))

          (let ((colors (overlay-get o 'beacon-colors)))
            (if (not colors)
                (move-overlay o (1- (point)) (point))
          (let ((colors (overlay-get o 'beacon-colors)))
            (if (not colors)
                (move-overlay o (1- (point)) (point))


@@ -275,10 +319,27 @@ Only returns `beacon-size' elements."
              (beacon--ov-put-after-string o colors)
              (forward-char 1))))))))
 
              (beacon--ov-put-after-string o colors)
              (forward-char 1))))))))
 

+;;;###autoload

 (defun beacon-blink ()
 (defun beacon-blink ()

-  "Blink the beacon at the position of the cursor."
+  "Blink the beacon at the position of the cursor.
+Unlike `beacon-blink-automated', the beacon will blink
+unconditionally (even if `beacon-mode' is disabled), and this can
+be invoked as a user command or called from lisp code."

   (interactive)
   (beacon--vanish)
   (interactive)
   (beacon--vanish)

+  (run-hooks 'beacon-before-blink-hook)
+  (beacon--shine)
+  (setq beacon--timer
+        (run-at-time beacon-blink-delay
+                     (/ beacon-blink-duration 1.0 beacon-size)
+                     #'beacon--dec)))
+
+(defun beacon-blink-automated ()
+  "If appropriate, blink the beacon at the position of the cursor.
+Unlike `beacon-blink', the blinking is conditioned on a series of
+variables: `beacon-mode', `beacon-dont-blink-commands',
+`beacon-dont-blink-major-modes', and
+`beacon-dont-blink-predicates'."

   ;; Record vars here in case something is blinking outside the
   ;; command loop.
   (beacon--record-vars)
   ;; Record vars here in case something is blinking outside the
   ;; command loop.
   (beacon--record-vars)


@@ -286,34 +347,38 @@ Only returns `beacon-size' elements."
               (run-hook-with-args-until-success 'beacon-dont-blink-predicates)
               (seq-find #'derived-mode-p beacon-dont-blink-major-modes)
               (memq (or this-command last-command) beacon-dont-blink-commands))
               (run-hook-with-args-until-success 'beacon-dont-blink-predicates)
               (seq-find #'derived-mode-p beacon-dont-blink-major-modes)
               (memq (or this-command last-command) beacon-dont-blink-commands))

-    (beacon--shine)
-    (setq beacon--timer
-          (run-at-time beacon-blink-delay
-                       (/ beacon-blink-duration 1.0 beacon-size)
-                       #'beacon--dec))))
+    (beacon-blink)))

 
 \f
 ;;; Movement detection
 
 \f
 ;;; Movement detection

-(defun beacon--movement-> (delta)
-  "Return non-nil if latest point movement is > DELTA.
-If DELTA is nil, return nil."
-  (and delta
+(defun beacon--movement-> (delta-y &optional delta-x)
+  "Return non-nil if latest vertical movement is > DELTA-Y.
+If DELTA-Y is nil, return nil.
+The same is true for DELTA-X and horizonta movement."
+  (and delta-y

        (markerp beacon--previous-place)
        (equal (marker-buffer beacon--previous-place)
               (current-buffer))
        ;; Quick check that prevents running the code below in very
        ;; short movements (like typing).
        (> (abs (- (point) beacon--previous-place))
        (markerp beacon--previous-place)
        (equal (marker-buffer beacon--previous-place)
               (current-buffer))
        ;; Quick check that prevents running the code below in very
        ;; short movements (like typing).
        (> (abs (- (point) beacon--previous-place))

-          delta)
-       ;; Check if the movement was >= DELTA lines by moving DELTA
-       ;; lines. `count-screen-lines' is too slow if the movement had
-       ;; thousands of lines.
-       (save-excursion
-         (let ((p (point)))
-           (goto-char (min beacon--previous-place p))
-           (vertical-motion delta)
-           (> (max p beacon--previous-place)
-              (line-beginning-position))))))
+          delta-y)
+       ;; Col movement.
+       (or (and delta-x
+                (> (abs (- (current-column)
+                           (save-excursion
+                             (goto-char beacon--previous-place)
+                             (current-column))))
+                   delta-x))
+           ;; Check if the movement was >= DELTA lines by moving DELTA
+           ;; lines. `count-screen-lines' is too slow if the movement had
+           ;; thousands of lines.
+           (save-excursion
+             (let ((p (point)))
+               (goto-char (min beacon--previous-place p))
+               (vertical-motion delta-y)
+               (> (max p beacon--previous-place)
+                  (line-beginning-position)))))))

 
 (defun beacon--maybe-push-mark ()
   "Push mark if it seems to be safe."
 
 (defun beacon--maybe-push-mark ()
   "Push mark if it seems to be safe."


@@ -322,27 +387,30 @@ If DELTA is nil, return nil."
     (let ((head (car mark-ring)))
       (when (and (eq beacon--previous-mark-head head)
                  (not (equal head beacon--previous-place)))
     (let ((head (car mark-ring)))
       (when (and (eq beacon--previous-mark-head head)
                  (not (equal head beacon--previous-place)))

-        (push-mark beacon--previous-place)))))
+        (push-mark beacon--previous-place 'silent)))))

 
 (defun beacon--post-command ()
   "Blink if point moved very far."
   (cond
 
 (defun beacon--post-command ()
   "Blink if point moved very far."
   (cond

-   ((not (markerp beacon--previous-place))
-    (beacon--vanish))
+   ;; Sanity check.
+   ((not (markerp beacon--previous-place)))
+   ;; Blink for switching buffers.
+   ((and beacon-blink-when-buffer-changes
+         (not (eq (marker-buffer beacon--previous-place)
+                  (current-buffer))))
+    (beacon-blink-automated))

    ;; Blink for switching windows.
    ((and beacon-blink-when-window-changes
          (not (eq beacon--previous-window (selected-window))))
    ;; Blink for switching windows.
    ((and beacon-blink-when-window-changes
          (not (eq beacon--previous-window (selected-window))))

-    (beacon-blink))
+    (beacon-blink-automated))

    ;; Blink for scrolling.
    ;; Blink for scrolling.

-   ((and beacon-blink-when-window-scrolls
-         beacon--window-scrolled
+   ((and beacon--window-scrolled

          (equal beacon--window-scrolled (selected-window)))
          (equal beacon--window-scrolled (selected-window)))

-    (beacon-blink))
+    (beacon-blink-automated))

    ;; Blink for movement
    ;; Blink for movement

-   ((beacon--movement-> beacon-blink-when-point-moves)
-    (beacon-blink))
-   ;; Even if we don't blink, vanish any previous beacon.
-   (t (beacon--vanish)))
+   ((beacon--movement-> beacon-blink-when-point-moves-vertically
+                  beacon-blink-when-point-moves-horizontally)
+    (beacon-blink-automated)))

   (beacon--maybe-push-mark)
   (setq beacon--window-scrolled nil))
 
   (beacon--maybe-push-mark)
   (setq beacon--window-scrolled nil))
 


@@ -355,17 +423,18 @@ scrolled window might not be active, but we only know that at
 
 If invoked outside the command loop, `post-command-hook' would be
 unreliable, so just blink immediately."
 
 If invoked outside the command loop, `post-command-hook' would be
 unreliable, so just blink immediately."

-  (unless (and (equal beacon--previous-window-start start-pos)
-               (equal beacon--previous-window win))
+  (unless (or (and (equal beacon--previous-window-start start-pos)
+                   (equal beacon--previous-window win))
+              (not beacon-blink-when-window-scrolls))

     (if this-command
         (setq beacon--window-scrolled win)
       (setq beacon--window-scrolled nil)
     (if this-command
         (setq beacon--window-scrolled win)
       (setq beacon--window-scrolled nil)

-      (beacon-blink))))
+      (beacon-blink-automated))))

 
 (defun beacon--blink-on-focus ()
   "Blink if `beacon-blink-when-focused' is non-nil"
   (when beacon-blink-when-focused
 
 (defun beacon--blink-on-focus ()
   "Blink if `beacon-blink-when-focused' is non-nil"
   (when beacon-blink-when-focused

-    (beacon-blink)))
+    (beacon-blink-automated)))

 
 \f
 ;;; Minor-mode
 
 \f
 ;;; Minor-mode


@@ -386,11 +455,13 @@ unreliable, so just blink immediately."
         (add-hook 'window-scroll-functions #'beacon--window-scroll-function)
         (add-hook 'focus-in-hook #'beacon--blink-on-focus)
         (add-hook 'post-command-hook #'beacon--post-command)
         (add-hook 'window-scroll-functions #'beacon--window-scroll-function)
         (add-hook 'focus-in-hook #'beacon--blink-on-focus)
         (add-hook 'post-command-hook #'beacon--post-command)

+        (add-hook 'before-change-functions #'beacon--vanish)

         (add-hook 'pre-command-hook #'beacon--record-vars)
         (add-hook 'pre-command-hook #'beacon--vanish))
     (remove-hook 'focus-in-hook #'beacon--blink-on-focus)
     (remove-hook 'window-scroll-functions #'beacon--window-scroll-function)
     (remove-hook 'post-command-hook #'beacon--post-command)
         (add-hook 'pre-command-hook #'beacon--record-vars)
         (add-hook 'pre-command-hook #'beacon--vanish))
     (remove-hook 'focus-in-hook #'beacon--blink-on-focus)
     (remove-hook 'window-scroll-functions #'beacon--window-scroll-function)
     (remove-hook 'post-command-hook #'beacon--post-command)

+    (remove-hook 'before-change-functions #'beacon--vanish)

     (remove-hook 'pre-command-hook #'beacon--record-vars)
     (remove-hook 'pre-command-hook #'beacon--vanish)))
 
     (remove-hook 'pre-command-hook #'beacon--record-vars)
     (remove-hook 'pre-command-hook #'beacon--vanish)))