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