code.delx.au - gnu-emacs-elpa/blob - beacon.el

   1 ;;; beacon.el --- Highlight the cursor whenever the window scrolls  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
   6 ;; URL: https://github.com/Malabarba/beacon
   7 ;; Keywords: convenience
   8 ;; Version: 0.1
   9 ;; Package-Requires: ((seq "1.9"))
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is a global minor-mode. Turn it on everywhere with:
  27 ;; ┌────
  28 ;; │ (beacon-mode 1)
  29 ;; └────
  30 ;;
  31 ;; Whenever the window scrolls a light will shine on top of your cursor so
  32 ;; you know where it is.
  33 ;;
  34 ;; That’s it.
  35 ;;
  36 ;;
  37 ;; 1 Customizations
  38 ;; ════════════════
  39 ;;
  40 ;;   • The appearance of the beacon is configured by `beacon-size' and
  41 ;;     `beacon-color'.
  42 ;;
  43 ;;   • The duration is configured by `beacon-blink-duration' and
  44 ;;     `beacon-blink-delay'.
  45 ;;
  46 ;;   • To customize /when/ the beacon should blink at all, configure
  47 ;;     `beacon-blink-when-window-scrolls',
  48 ;;     `beacon-blink-when-window-changes', and
  49 ;;     `beacon-blink-when-point-moves'.
  50 ;;
  51 ;;   • To prevent the beacon from blinking only on some major-modes,
  52 ;;     configure `beacon-dont-blink-major-modes'. For specific buffers, you
  53 ;;     can do `(setq-local beacon-mode nil)'. For even more refined
  54 ;;     control, configure `beacon-dont-blink-predicates'
  55 ;;
  56 ;;   • Beacon can also push the mark for you whenever point moves a long
  57 ;;     distance. For this, configure `beacon-push-mark'.
  58
  59 ;;; Code:
  60
  61 (require 'seq)
  62
  63 (defgroup beacon nil
  64   "Customization group for beacon."
  65   :group 'emacs
  66   :prefix "beacon-")
  67
  68 (defvar beacon--timer nil)
  69
  70 (defcustom beacon-push-mark nil
  71   "Should the mark be pushed before long movements?
  72 If nil, `beacon' will not push the mark.
  73 Otherwise this should be a number, and `beacon' will push the
  74 mark whenever point moves more than that many lines."
  75   :type '(choice integer (const nil)))
  76
  77 (defcustom beacon-blink-when-point-moves nil
  78   "Should the beacon blink when moving a long distance?
  79 If nil, don't blink due to plain movement.
  80 If non-nil, this should be an integer, which is the minimum
  81 movement distance (in lines) that triggers a beacon blink."
  82   :type '(choice integer (const nil)))
  83
  84 (defcustom beacon-blink-when-buffer-changes t
  85   "Should the beacon blink when changing buffer?"
  86   :type 'boolean)
  87
  88 (defcustom beacon-blink-when-window-scrolls t
  89   "Should the beacon blink when the window scrolls?"
  90   :type 'boolean)
  91
  92 (defcustom beacon-blink-when-window-changes t
  93   "Should the beacon blink when the window changes?"
  94   :type 'boolean)
  95
  96 (defcustom beacon-blink-duration 0.3
  97   "Time, in seconds, that the blink should last."
  98   :type 'number)
  99
 100 (defcustom beacon-blink-delay 0.3
 101   "Time, in seconds, before starting to fade the beacon."
 102   :type 'number)
 103
 104 (defcustom beacon-size 40
 105   "Size of the beacon in characters."
 106   :type 'number)
 107
 108 (defcustom beacon-color 0.5
 109   "Color of the beacon.
 110 This can be a string or a number.
 111
 112 If it is a number, the color is taken to be white or
 113 black (depending on the current theme's background) and this
 114 number is a float between 0 and 1 specifing the brightness.
 115
 116 If it is a string, it is a color name or specification,
 117 e.g. \"#666600\"."
 118   :type '(choice number color))
 119
 120 (defcustom beacon-dont-blink-predicates nil
 121   "A list of predicates that prevent the beacon blink.
 122 These predicate functions are called in order, with no
 123 arguments, before blinking the beacon.  If any returns
 124 non-nil, the beacon will not blink."
 125   :type 'hook)
 126
 127 (add-hook 'beacon-dont-blink-predicates (lambda () (bound-and-true-p hl-line-mode)))
 128 (add-hook 'beacon-dont-blink-predicates #'window-minibuffer-p)
 129
 130 (defcustom beacon-dont-blink-major-modes '(magit-status-mode)
 131   "A list of major-modes where the beacon won't blink.
 132 Whenever the current buffer satisfies `derived-mode-p' for
 133 one of the major-modes on this list, the beacon will not
 134 blink."
 135   :type '(repeat symbol))
 136
 137 (defcustom beacon-dont-blink-commands '(recenter-top-bottom)
 138   "A list of commands that should not make the beacon blink.
 139 Use this for commands that scroll the window in very
 140 predictable ways, when the blink would be more distracting
 141 than helpful.."
 142   :type '(repeat symbol))
 143
 144 \f
 145 ;;; Overlays
 146 (defvar beacon--ovs nil)
 147
 148 (defconst beacon-overlay-priority (/ most-positive-fixnum 2)
 149   "Priotiy used on all of our overlays.")
 150
 151 (defun beacon--make-overlay (length &rest properties)
 152   "Put an overlay at point with background COLOR."
 153   (let ((ov (make-overlay (point) (+ length (point)))))
 154     (overlay-put ov 'beacon t)
 155     ;; Our overlay is very temporary, so we take the liberty of giving
 156     ;; it a high priority.
 157     (overlay-put ov 'priority beacon-overlay-priority)
 158     (overlay-put ov 'window (selected-window))
 159     (while properties
 160       (overlay-put ov (pop properties) (pop properties)))
 161     (push ov beacon--ovs)
 162     ov))
 163
 164 (defun beacon--colored-overlay (color)
 165   "Put an overlay at point with background COLOR."
 166   (beacon--make-overlay 1 'face (list :background color)))
 167
 168 (defun beacon--ov-put-after-string (overlay colors)
 169   "Add an after-string property to OVERLAY.
 170 The property's value is a string of spaces with background
 171 COLORS applied to each one.
 172 If COLORS is nil, OVERLAY is deleted!"
 173   (if (not colors)
 174       (when (overlayp overlay)
 175         (delete-overlay overlay))
 176     (overlay-put overlay 'beacon-colors colors)
 177     (overlay-put overlay 'after-string
 178                  (propertize
 179                   (mapconcat (lambda (c) (propertize " " 'face (list :background c)))
 180                              colors
 181                              "")
 182                   'cursor 1000))))
 183
 184 (defun beacon--after-string-overlay (colors)
 185   "Put an overlay at point with an after-string property.
 186 The property's value is a string of spaces with background
 187 COLORS applied to each one."
 188   ;; The after-string must not be longer than the remaining columns
 189   ;; from point to right window-end else it will be wrapped around.
 190   (let ((colors (seq-take colors (- (window-width) (current-column)))))
 191     (beacon--ov-put-after-string (beacon--make-overlay 0) colors)))
 192
 193 (defun beacon--ov-at-point ()
 194   (car (or (seq-filter (lambda (o) (overlay-get o 'beacon))
 195                      (overlays-in (point) (point)))
 196            (seq-filter (lambda (o) (overlay-get o 'beacon))
 197                      (overlays-at (point))))))
 198
 199 (defun beacon--vanish ()
 200   "Turn off the beacon."
 201   (when (timerp beacon--timer)
 202     (cancel-timer beacon--timer))
 203   (mapc #'delete-overlay beacon--ovs)
 204   (setq beacon--ovs nil))
 205
 206 \f
 207 ;;; Colors
 208 (defun beacon--int-range (a b)
 209   "Return a list of integers between A inclusive and B exclusive.
 210 Only returns `beacon-size' elements."
 211   (let ((d (/ (- b a) beacon-size))
 212         (out (list a)))
 213     (dotimes (_ (1- beacon-size))
 214       (push (+ (car out) d) out))
 215     (nreverse out)))
 216
 217 (defun beacon--color-range ()
 218   "Return a list of background colors for the beacon."
 219   (let* ((bg (color-values (face-attribute 'default :background)))
 220          (fg (cond
 221               ((stringp beacon-color) (color-values beacon-color))
 222               ((< (color-distance "black" bg)
 223                   (color-distance "white" bg))
 224                (make-list 3 (* beacon-color 65535)))
 225               (t (make-list 3 (* (- 1 beacon-color) 65535))))))
 226     (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b))
 227            (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n))))
 228                    [0 1 2]))))
 229
 230 \f
 231 ;;; Blinking
 232 (defun beacon--shine ()
 233   "Shine a beacon at point."
 234   (let ((colors (beacon--color-range)))
 235     (save-excursion
 236       (while colors
 237         (if (looking-at "$")
 238             (progn
 239               (beacon--after-string-overlay colors)
 240               (setq colors nil))
 241           (beacon--colored-overlay (pop colors))
 242           (forward-char 1))))))
 243
 244 (defun beacon--dec ()
 245   "Decrease the beacon brightness by one."
 246   (pcase (beacon--ov-at-point)
 247     (`nil (beacon--vanish))
 248     ((and o (let c (overlay-get o 'beacon-colors)) (guard c))
 249      (beacon--ov-put-after-string o (cdr c)))
 250     (o
 251      (delete-overlay o)
 252      (save-excursion
 253        (while (progn (forward-char 1)
 254                      (setq o (beacon--ov-at-point)))
 255          (let ((colors (overlay-get o 'beacon-colors)))
 256            (if (not colors)
 257                (move-overlay o (1- (point)) (point))
 258              (forward-char -1)
 259              (beacon--colored-overlay (pop colors))
 260              (beacon--ov-put-after-string o colors)
 261              (forward-char 1))))))))
 262
 263 (defun beacon-blink ()
 264   "Blink the beacon at the position of the cursor."
 265   (interactive)
 266   (beacon--vanish)
 267   (unless (or (not beacon-mode)
 268               (run-hook-with-args-until-success 'beacon-dont-blink-predicates)
 269               (seq-find #'derived-mode-p beacon-dont-blink-major-modes)
 270               (memq (or this-command last-command) beacon-dont-blink-commands))
 271     (beacon--shine)
 272     (setq beacon--timer
 273           (run-at-time beacon-blink-delay
 274                        (/ beacon-blink-duration 1.0 beacon-size)
 275                        #'beacon--dec))))
 276
 277 \f
 278 ;;; Movement detection
 279 (defvar beacon--window-scrolled nil)
 280 (defvar beacon--previous-place nil)
 281 (defvar beacon--previous-mark-head nil)
 282 (defvar beacon--previous-window nil)
 283
 284 (defun beacon--movement-> (delta)
 285   "Return non-nil if latest point movement is > DELTA.
 286 If DELTA is nil, return nil."
 287   (and delta
 288        (markerp beacon--previous-place)
 289        (equal (marker-buffer beacon--previous-place)
 290               (current-buffer))
 291        (> (abs (- (point) beacon--previous-place))
 292           delta)
 293        (> (count-screen-lines (min (point) beacon--previous-place)
 294                               (max (point) beacon--previous-place))
 295           delta)))
 296
 297 (defun beacon--maybe-push-mark ()
 298   "Push mark if it seems to be safe."
 299   (when (and (not mark-active)
 300              (beacon--movement-> beacon-push-mark))
 301     (let ((head (car mark-ring)))
 302       (when (and (eq beacon--previous-mark-head head)
 303                  (not (equal head beacon--previous-place)))
 304         (push-mark beacon--previous-place)))))
 305
 306 (defun beacon--post-command ()
 307   "Blink if point moved very far."
 308   (cond
 309    ((not (markerp beacon--previous-place))
 310     (beacon--vanish))
 311    ;; Blink for switching windows.
 312    ((and beacon-blink-when-window-changes
 313          (not (eq beacon--previous-window (selected-window))))
 314     (beacon-blink))
 315    ;; Blink for scrolling.
 316    ((and beacon-blink-when-window-scrolls
 317          beacon--window-scrolled
 318          (equal beacon--window-scrolled (selected-window)))
 319     (beacon-blink))
 320    ;; Blink for movement
 321    ((beacon--movement-> beacon-blink-when-point-moves)
 322     (beacon-blink))
 323    ;; Even if we don't blink, vanish any previous beacon.
 324    (t (beacon--vanish)))
 325   (beacon--maybe-push-mark)
 326   (setq beacon--window-scrolled nil)
 327   (unless (window-minibuffer-p)
 328     (setq beacon--previous-mark-head (car mark-ring))
 329     (setq beacon--previous-place (point-marker))
 330     (setq beacon--previous-window (selected-window))))
 331
 332 (defun beacon--window-scroll-function (win _start-pos)
 333   "Blink the beacon or record that window has been scrolled.
 334 If invoked during the command loop, record the current window so
 335 that it may be blinked on post-command.  This is because the
 336 scrolled window might not be active, but we only know that at
 337 `post-command-hook'.
 338
 339 If invoked outside the command loop, `post-command-hook' would be
 340 unreliable, so just blink immediately."
 341   (if this-command
 342       (setq beacon--window-scrolled win)
 343     (setq beacon--window-scrolled nil)
 344     (beacon-blink)))
 345
 346 \f
 347 ;;; Minor-mode
 348 (defcustom beacon-lighter
 349   (cond
 350    ((char-displayable-p ?💡) " 💡")
 351    ((char-displayable-p ?Λ) " Λ")
 352    (t " *"))
 353   "Lighter string used on the mode-line."
 354   :type 'string)
 355
 356 ;;;###autoload
 357 (define-minor-mode beacon-mode
 358   nil nil beacon-lighter nil
 359   :global t
 360   (if beacon-mode
 361       (progn
 362         (add-hook 'window-scroll-functions #'beacon--window-scroll-function)
 363         (add-hook 'post-command-hook #'beacon--post-command)
 364         (add-hook 'pre-command-hook #'beacon--vanish))
 365     (remove-hook 'window-scroll-functions #'beacon--window-scroll-function)
 366     (remove-hook 'post-command-hook #'beacon--post-command)
 367     (remove-hook 'pre-command-hook #'beacon--vanish)))
 368
 369 (provide 'beacon)
 370 ;;; beacon.el ends here