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