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