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

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