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