Version 1.3.1
[gnu-emacs-elpa] / 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: 1.3.1
9 ;; Package-Requires: ((seq "2.14"))
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 inf-ruby-mode
154 gnus-summary-mode gnus-group-mode)
155 "A list of major-modes where the beacon won't blink.
156 Whenever the current buffer satisfies `derived-mode-p' for
157 one of the major-modes on this list, the beacon will not
158 blink."
159 :type '(repeat symbol))
160
161 (defcustom beacon-dont-blink-commands '(next-line previous-line
162 forward-line)
163 "A list of commands that should not make the beacon blink.
164 Use this for commands that scroll the window in very
165 predictable ways, when the blink would be more distracting
166 than helpful.."
167 :type '(repeat symbol))
168
169 (defcustom beacon-before-blink-hook nil
170 "Hook run immediately before blinking the beacon."
171 :type 'hook)
172
173 \f
174 ;;; Internal variables
175 (defvar beacon--window-scrolled nil)
176 (defvar beacon--previous-place nil)
177 (defvar beacon--previous-mark-head nil)
178 (defvar beacon--previous-window nil)
179 (defvar beacon--previous-window-start 0)
180
181 (defun beacon--record-vars ()
182 (unless (window-minibuffer-p)
183 (setq beacon--previous-mark-head (car mark-ring))
184 (setq beacon--previous-place (point-marker))
185 (setq beacon--previous-window (selected-window))
186 (setq beacon--previous-window-start (window-start))))
187
188 \f
189 ;;; Overlays
190 (defvar beacon--ovs nil)
191
192 (defconst beacon-overlay-priority (/ most-positive-fixnum 2)
193 "Priotiy used on all of our overlays.")
194
195 (defun beacon--make-overlay (length &rest properties)
196 "Put an overlay at point with background COLOR."
197 (let ((ov (make-overlay (point) (+ length (point)))))
198 (overlay-put ov 'beacon t)
199 ;; Our overlay is very temporary, so we take the liberty of giving
200 ;; it a high priority.
201 (overlay-put ov 'priority beacon-overlay-priority)
202 (overlay-put ov 'window (selected-window))
203 (while properties
204 (overlay-put ov (pop properties) (pop properties)))
205 (push ov beacon--ovs)
206 ov))
207
208 (defun beacon--colored-overlay (color)
209 "Put an overlay at point with background COLOR."
210 (beacon--make-overlay 1 'face (list :background color)))
211
212 (defun beacon--ov-put-after-string (overlay colors)
213 "Add an after-string property to OVERLAY.
214 The property's value is a string of spaces with background
215 COLORS applied to each one.
216 If COLORS is nil, OVERLAY is deleted!"
217 (if (not colors)
218 (when (overlayp overlay)
219 (delete-overlay overlay))
220 (overlay-put overlay 'beacon-colors colors)
221 (overlay-put overlay 'after-string
222 (propertize
223 (mapconcat (lambda (c) (propertize " " 'face (list :background c)))
224 colors
225 "")
226 'cursor 1000))))
227
228 (defun beacon--after-string-overlay (colors)
229 "Put an overlay at point with an after-string property.
230 The property's value is a string of spaces with background
231 COLORS applied to each one."
232 ;; The after-string must not be longer than the remaining columns
233 ;; from point to right window-end else it will be wrapped around.
234 (let ((colors (seq-take colors (- (window-width) (current-column)))))
235 (beacon--ov-put-after-string (beacon--make-overlay 0) colors)))
236
237 (defun beacon--ov-at-point ()
238 (car (or (seq-filter (lambda (o) (overlay-get o 'beacon))
239 (overlays-in (point) (point)))
240 (seq-filter (lambda (o) (overlay-get o 'beacon))
241 (overlays-at (point))))))
242
243 (defun beacon--vanish (&rest _)
244 "Turn off the beacon."
245 (unless (string-match "\\` \\*\\(temp-buffer\\|Echo Area.*\\)\\*"
246 (buffer-name))
247 (when (timerp beacon--timer)
248 (cancel-timer beacon--timer))
249 (mapc #'delete-overlay beacon--ovs)
250 (setq beacon--ovs nil)))
251
252 \f
253 ;;; Colors
254 (defun beacon--int-range (a b)
255 "Return a list of integers between A inclusive and B exclusive.
256 Only returns `beacon-size' elements."
257 (let ((d (/ (- b a) beacon-size))
258 (out (list a)))
259 (dotimes (_ (1- beacon-size))
260 (push (+ (car out) d) out))
261 (nreverse out)))
262
263 (defun beacon--color-range ()
264 "Return a list of background colors for the beacon."
265 (let* ((default-bg (or (save-excursion
266 (unless (eobp)
267 (forward-line 1)
268 (unless (or (bobp) (not (bolp)))
269 (forward-char -1)))
270 (background-color-at-point))
271 (face-background 'default)))
272 (bg (color-values (if (or (not (stringp default-bg))
273 (string-match "\\`unspecified-" default-bg))
274 (face-attribute 'beacon-fallback-background :background)
275 default-bg)))
276 (fg (cond
277 ((stringp beacon-color) (color-values beacon-color))
278 ((and (stringp bg)
279 (< (color-distance "black" bg)
280 (color-distance "white" bg)))
281 (make-list 3 (* beacon-color 65535)))
282 (t (make-list 3 (* (- 1 beacon-color) 65535))))))
283 (apply #'seq-mapn (lambda (r g b) (format "#%04x%04x%04x" r g b))
284 (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n))))
285 [0 1 2]))))
286
287 \f
288 ;;; Blinking
289 (defun beacon--shine ()
290 "Shine a beacon at point."
291 (let ((colors (beacon--color-range)))
292 (save-excursion
293 (while colors
294 (if (looking-at "$")
295 (progn
296 (beacon--after-string-overlay colors)
297 (setq colors nil))
298 (beacon--colored-overlay (pop colors))
299 (forward-char 1))))))
300
301 (defun beacon--dec ()
302 "Decrease the beacon brightness by one."
303 (pcase (beacon--ov-at-point)
304 (`nil (beacon--vanish))
305 ((and o (let c (overlay-get o 'beacon-colors)) (guard c))
306 (beacon--ov-put-after-string o (cdr c)))
307 (o
308 (delete-overlay o)
309 (save-excursion
310 (while (and (condition-case nil
311 (progn (forward-char 1) t)
312 (end-of-buffer nil))
313 (setq o (beacon--ov-at-point)))
314 (let ((colors (overlay-get o 'beacon-colors)))
315 (if (not colors)
316 (move-overlay o (1- (point)) (point))
317 (forward-char -1)
318 (beacon--colored-overlay (pop colors))
319 (beacon--ov-put-after-string o colors)
320 (forward-char 1))))))))
321
322 ;;;###autoload
323 (defun beacon-blink ()
324 "Blink the beacon at the position of the cursor.
325 Unlike `beacon-blink-automated', the beacon will blink
326 unconditionally (even if `beacon-mode' is disabled), and this can
327 be invoked as a user command or called from lisp code."
328 (interactive)
329 (beacon--vanish)
330 (run-hooks 'beacon-before-blink-hook)
331 (beacon--shine)
332 (setq beacon--timer
333 (run-at-time beacon-blink-delay
334 (/ beacon-blink-duration 1.0 beacon-size)
335 #'beacon--dec)))
336
337 (defun beacon-blink-automated ()
338 "If appropriate, blink the beacon at the position of the cursor.
339 Unlike `beacon-blink', the blinking is conditioned on a series of
340 variables: `beacon-mode', `beacon-dont-blink-commands',
341 `beacon-dont-blink-major-modes', and
342 `beacon-dont-blink-predicates'."
343 ;; Record vars here in case something is blinking outside the
344 ;; command loop.
345 (beacon--record-vars)
346 (unless (or (not beacon-mode)
347 (run-hook-with-args-until-success 'beacon-dont-blink-predicates)
348 (seq-find #'derived-mode-p beacon-dont-blink-major-modes)
349 (memq (or this-command last-command) beacon-dont-blink-commands))
350 (beacon-blink)))
351
352 \f
353 ;;; Movement detection
354 (defun beacon--movement-> (delta-y &optional delta-x)
355 "Return non-nil if latest vertical movement is > DELTA-Y.
356 If DELTA-Y is nil, return nil.
357 The same is true for DELTA-X and horizonta movement."
358 (and delta-y
359 (markerp beacon--previous-place)
360 (equal (marker-buffer beacon--previous-place)
361 (current-buffer))
362 ;; Quick check that prevents running the code below in very
363 ;; short movements (like typing).
364 (> (abs (- (point) beacon--previous-place))
365 delta-y)
366 ;; Col movement.
367 (or (and delta-x
368 (> (abs (- (current-column)
369 (save-excursion
370 (goto-char beacon--previous-place)
371 (current-column))))
372 delta-x))
373 ;; Check if the movement was >= DELTA lines by moving DELTA
374 ;; lines. `count-screen-lines' is too slow if the movement had
375 ;; thousands of lines.
376 (save-excursion
377 (let ((p (point)))
378 (goto-char (min beacon--previous-place p))
379 (vertical-motion delta-y)
380 (> (max p beacon--previous-place)
381 (line-beginning-position)))))))
382
383 (defun beacon--maybe-push-mark ()
384 "Push mark if it seems to be safe."
385 (when (and (not mark-active)
386 (beacon--movement-> beacon-push-mark))
387 (let ((head (car mark-ring)))
388 (when (and (eq beacon--previous-mark-head head)
389 (not (equal head beacon--previous-place)))
390 (push-mark beacon--previous-place 'silent)))))
391
392 (defun beacon--post-command ()
393 "Blink if point moved very far."
394 (cond
395 ;; Sanity check.
396 ((not (markerp beacon--previous-place)))
397 ;; Blink for switching buffers.
398 ((and beacon-blink-when-buffer-changes
399 (not (eq (marker-buffer beacon--previous-place)
400 (current-buffer))))
401 (beacon-blink-automated))
402 ;; Blink for switching windows.
403 ((and beacon-blink-when-window-changes
404 (not (eq beacon--previous-window (selected-window))))
405 (beacon-blink-automated))
406 ;; Blink for scrolling.
407 ((and beacon--window-scrolled
408 (equal beacon--window-scrolled (selected-window)))
409 (beacon-blink-automated))
410 ;; Blink for movement
411 ((beacon--movement-> beacon-blink-when-point-moves-vertically
412 beacon-blink-when-point-moves-horizontally)
413 (beacon-blink-automated)))
414 (beacon--maybe-push-mark)
415 (setq beacon--window-scrolled nil))
416
417 (defun beacon--window-scroll-function (win start-pos)
418 "Blink the beacon or record that window has been scrolled.
419 If invoked during the command loop, record the current window so
420 that it may be blinked on post-command. This is because the
421 scrolled window might not be active, but we only know that at
422 `post-command-hook'.
423
424 If invoked outside the command loop, `post-command-hook' would be
425 unreliable, so just blink immediately."
426 (unless (or (and (equal beacon--previous-window-start start-pos)
427 (equal beacon--previous-window win))
428 (not beacon-blink-when-window-scrolls))
429 (if this-command
430 (setq beacon--window-scrolled win)
431 (setq beacon--window-scrolled nil)
432 (beacon-blink-automated))))
433
434 (defun beacon--blink-on-focus ()
435 "Blink if `beacon-blink-when-focused' is non-nil"
436 (when beacon-blink-when-focused
437 (beacon-blink-automated)))
438
439 \f
440 ;;; Minor-mode
441 (defcustom beacon-lighter
442 (cond
443 ;; ((char-displayable-p ?💡) " 💡")
444 ;; ((char-displayable-p ?Λ) " Λ")
445 (t " (*)"))
446 "Lighter string used on the mode-line."
447 :type 'string)
448
449 ;;;###autoload
450 (define-minor-mode beacon-mode
451 nil nil beacon-lighter nil
452 :global t
453 (if beacon-mode
454 (progn
455 (add-hook 'window-scroll-functions #'beacon--window-scroll-function)
456 (add-hook 'focus-in-hook #'beacon--blink-on-focus)
457 (add-hook 'post-command-hook #'beacon--post-command)
458 (add-hook 'before-change-functions #'beacon--vanish)
459 (add-hook 'pre-command-hook #'beacon--record-vars)
460 (add-hook 'pre-command-hook #'beacon--vanish))
461 (remove-hook 'focus-in-hook #'beacon--blink-on-focus)
462 (remove-hook 'window-scroll-functions #'beacon--window-scroll-function)
463 (remove-hook 'post-command-hook #'beacon--post-command)
464 (remove-hook 'before-change-functions #'beacon--vanish)
465 (remove-hook 'pre-command-hook #'beacon--record-vars)
466 (remove-hook 'pre-command-hook #'beacon--vanish)))
467
468 (provide 'beacon)
469 ;;; beacon.el ends here
470
471 ;; Local Variables:
472 ;; indent-tabs-mode: nil
473 ;; End: