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