X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/e41ab416d9de2946bba59440fb397c8f258dc757..02cc76051de74d3a81ec6b988ea3058a9fa73cfa:/packages/beacon/beacon.el diff --git a/packages/beacon/beacon.el b/packages/beacon/beacon.el index 6433ba054..422614919 100644 --- a/packages/beacon/beacon.el +++ b/packages/beacon/beacon.el @@ -5,8 +5,8 @@ ;; Author: Artur Malabarba ;; URL: https://github.com/Malabarba/beacon ;; Keywords: convenience -;; Version: 0.3 -;; Package-Requires: ((seq "1.9")) +;; Version: 1.0 +;; Package-Requires: ((seq "1.11")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -38,6 +38,24 @@ ;;; Code: (require 'seq) +(require 'faces) +(unless (fboundp 'seq-mapn) + ;; This is for people who are on outdated Emacs snapshots. Will be + ;; deleted in a couple of weeks. + (defun seq-mapn (function sequence &rest sequences) + "Like `seq-map' but FUNCTION is mapped over all SEQUENCES. +The arity of FUNCTION must match the number of SEQUENCES, and the +mapping stops on the shortest sequence. +Return a list of the results. + +\(fn FUNCTION SEQUENCES...)" + (let ((result nil) + (sequences (seq-map (lambda (s) (seq-into s 'list)) + (cons sequence sequences)))) + (while (not (memq nil sequences)) + (push (apply function (seq-map #'car sequences)) result) + (setq sequences (seq-map #'cdr sequences))) + (nreverse result)))) (defgroup beacon nil "Customization group for beacon." @@ -53,13 +71,20 @@ Otherwise this should be a number, and `beacon' will push the mark whenever point moves more than that many lines." :type '(choice integer (const nil))) -(defcustom beacon-blink-when-point-moves nil - "Should the beacon blink when moving a long distance? -If nil, don't blink due to plain movement. +(defcustom beacon-blink-when-point-moves-vertically nil + "Should the beacon blink when moving a long distance vertically? +If nil, don't blink due to vertical movement. If non-nil, this should be an integer, which is the minimum movement distance (in lines) that triggers a beacon blink." :type '(choice integer (const nil))) +(defcustom beacon-blink-when-point-moves-horizontally nil + "Should the beacon blink when moving a long distance horizontally? +If nil, don't blink due to horizontal movement. +If non-nil, this should be an integer, which is the minimum +movement distance (in columns) that triggers a beacon blink." + :type '(choice integer (const nil))) + (defcustom beacon-blink-when-buffer-changes t "Should the beacon blink when changing buffer?" :type 'boolean) @@ -103,6 +128,13 @@ If it is a string, it is a color name or specification, e.g. \"#666600\"." :type '(choice number color)) +(defface beacon-fallback-background + '((((class color) (background light)) (:background "black")) + (((class color) (background dark)) (:background "white"))) + "Fallback beacon background color. +Used in cases where the color can't be determined by Emacs. +Only the background of this face is used.") + (defvar beacon-dont-blink-predicates nil "A list of predicates that prevent the beacon blink. These predicate functions are called in order, with no @@ -117,14 +149,17 @@ For instance, if you want to disable beacon on buffers where (add-hook 'beacon-dont-blink-predicates #'window-minibuffer-p) -(defcustom beacon-dont-blink-major-modes '(magit-status-mode magit-popup-mode) +(defcustom beacon-dont-blink-major-modes '(t magit-status-mode magit-popup-mode + inf-ruby-mode + gnus-summary-mode gnus-group-mode) "A list of major-modes where the beacon won't blink. Whenever the current buffer satisfies `derived-mode-p' for one of the major-modes on this list, the beacon will not blink." :type '(repeat symbol)) -(defcustom beacon-dont-blink-commands '(recenter-top-bottom) +(defcustom beacon-dont-blink-commands '(next-line previous-line + forward-line) "A list of commands that should not make the beacon blink. Use this for commands that scroll the window in very predictable ways, when the blink would be more distracting @@ -197,9 +232,9 @@ COLORS applied to each one." (defun beacon--ov-at-point () (car (or (seq-filter (lambda (o) (overlay-get o 'beacon)) - (overlays-in (point) (point))) + (overlays-in (point) (point))) (seq-filter (lambda (o) (overlay-get o 'beacon)) - (overlays-at (point)))))) + (overlays-at (point)))))) (defun beacon--vanish () "Turn off the beacon." @@ -221,14 +256,25 @@ Only returns `beacon-size' elements." (defun beacon--color-range () "Return a list of background colors for the beacon." - (let* ((bg (color-values (face-attribute 'default :background))) + (let* ((default-bg (or (save-excursion + (unless (eobp) + (forward-line 1) + (unless (or (bobp) (not (bolp))) + (forward-char -1))) + (background-color-at-point)) + (face-background 'default))) + (bg (color-values (if (or (not (stringp default-bg)) + (string-match "\\`unspecified-" default-bg)) + (face-attribute 'beacon-fallback-background :background) + default-bg))) (fg (cond ((stringp beacon-color) (color-values beacon-color)) - ((< (color-distance "black" bg) - (color-distance "white" bg)) + ((and (stringp bg) + (< (color-distance "black" bg) + (color-distance "white" bg))) (make-list 3 (* beacon-color 65535))) (t (make-list 3 (* (- 1 beacon-color) 65535)))))) - (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b)) + (apply #'seq-mapn (lambda (r g b) (format "#%04x%04x%04x" r g b)) (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n)))) [0 1 2])))) @@ -255,8 +301,10 @@ Only returns `beacon-size' elements." (o (delete-overlay o) (save-excursion - (while (progn (forward-char 1) - (setq o (beacon--ov-at-point))) + (while (and (condition-case nil + (progn (forward-char 1) t) + (end-of-buffer nil)) + (setq o (beacon--ov-at-point))) (let ((colors (overlay-get o 'beacon-colors))) (if (not colors) (move-overlay o (1- (point)) (point)) @@ -265,10 +313,26 @@ Only returns `beacon-size' elements." (beacon--ov-put-after-string o colors) (forward-char 1)))))))) +;;;###autoload (defun beacon-blink () - "Blink the beacon at the position of the cursor." + "Blink the beacon at the position of the cursor. +Unlike `beacon-blink-automated', the beacon will blink +unconditionally (even if `beacon-mode' is disabled), and this can +be invoked as a user command or called from lisp code." (interactive) (beacon--vanish) + (beacon--shine) + (setq beacon--timer + (run-at-time beacon-blink-delay + (/ beacon-blink-duration 1.0 beacon-size) + #'beacon--dec))) + +(defun beacon-blink-automated () + "If appropriate, blink the beacon at the position of the cursor. +Unlike `beacon-blink', the blinking is conditioned on a series of +variables: `beacon-mode', `beacon-dont-blink-commands', +`beacon-dont-blink-major-modes', and +`beacon-dont-blink-predicates'." ;; Record vars here in case something is blinking outside the ;; command loop. (beacon--record-vars) @@ -276,34 +340,38 @@ Only returns `beacon-size' elements." (run-hook-with-args-until-success 'beacon-dont-blink-predicates) (seq-find #'derived-mode-p beacon-dont-blink-major-modes) (memq (or this-command last-command) beacon-dont-blink-commands)) - (beacon--shine) - (setq beacon--timer - (run-at-time beacon-blink-delay - (/ beacon-blink-duration 1.0 beacon-size) - #'beacon--dec)))) + (beacon-blink))) ;;; Movement detection -(defun beacon--movement-> (delta) - "Return non-nil if latest point movement is > DELTA. -If DELTA is nil, return nil." - (and delta +(defun beacon--movement-> (delta-y &optional delta-x) + "Return non-nil if latest vertical movement is > DELTA-Y. +If DELTA-Y is nil, return nil. +The same is true for DELTA-X and horizonta movement." + (and delta-y (markerp beacon--previous-place) (equal (marker-buffer beacon--previous-place) (current-buffer)) ;; Quick check that prevents running the code below in very ;; short movements (like typing). (> (abs (- (point) beacon--previous-place)) - delta) - ;; Check if the movement was >= DELTA lines by moving DELTA - ;; lines. `count-screen-lines' is too slow if the movement had - ;; thousands of lines. - (save-excursion - (let ((p (point))) - (goto-char (min beacon--previous-place p)) - (vertical-motion delta) - (> (max p beacon--previous-place) - (line-beginning-position)))))) + delta-y) + ;; Col movement. + (or (and delta-x + (> (abs (- (current-column) + (save-excursion + (goto-char beacon--previous-place) + (current-column)))) + delta-x)) + ;; Check if the movement was >= DELTA lines by moving DELTA + ;; lines. `count-screen-lines' is too slow if the movement had + ;; thousands of lines. + (save-excursion + (let ((p (point))) + (goto-char (min beacon--previous-place p)) + (vertical-motion delta-y) + (> (max p beacon--previous-place) + (line-beginning-position))))))) (defun beacon--maybe-push-mark () "Push mark if it seems to be safe." @@ -312,27 +380,25 @@ If DELTA is nil, return nil." (let ((head (car mark-ring))) (when (and (eq beacon--previous-mark-head head) (not (equal head beacon--previous-place))) - (push-mark beacon--previous-place))))) + (push-mark beacon--previous-place 'silent))))) (defun beacon--post-command () "Blink if point moved very far." (cond - ((not (markerp beacon--previous-place)) - (beacon--vanish)) + ;; Sanity check. + ((not (markerp beacon--previous-place))) ;; Blink for switching windows. ((and beacon-blink-when-window-changes (not (eq beacon--previous-window (selected-window)))) - (beacon-blink)) + (beacon-blink-automated)) ;; Blink for scrolling. - ((and beacon-blink-when-window-scrolls - beacon--window-scrolled + ((and beacon--window-scrolled (equal beacon--window-scrolled (selected-window))) - (beacon-blink)) + (beacon-blink-automated)) ;; Blink for movement - ((beacon--movement-> beacon-blink-when-point-moves) - (beacon-blink)) - ;; Even if we don't blink, vanish any previous beacon. - (t (beacon--vanish))) + ((beacon--movement-> beacon-blink-when-point-moves-vertically + beacon-blink-when-point-moves-horizontally) + (beacon-blink-automated))) (beacon--maybe-push-mark) (setq beacon--window-scrolled nil)) @@ -345,17 +411,18 @@ scrolled window might not be active, but we only know that at If invoked outside the command loop, `post-command-hook' would be unreliable, so just blink immediately." - (unless (and (equal beacon--previous-window-start start-pos) - (equal beacon--previous-window win)) + (unless (or (and (equal beacon--previous-window-start start-pos) + (equal beacon--previous-window win)) + (not beacon-blink-when-window-scrolls)) (if this-command (setq beacon--window-scrolled win) (setq beacon--window-scrolled nil) - (beacon-blink)))) + (beacon-blink-automated)))) (defun beacon--blink-on-focus () "Blink if `beacon-blink-when-focused' is non-nil" (when beacon-blink-when-focused - (beacon-blink))) + (beacon-blink-automated))) ;;; Minor-mode