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