X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/19096a62529a75ea8999c3ee31babe097e3219b1..f1bb231bd5f6247b2e792b5ce7ee7ef6a0973122:/beacon.el diff --git a/beacon.el b/beacon.el index dd1976d5a..ba47f18ea 100644 --- a/beacon.el +++ b/beacon.el @@ -6,7 +6,7 @@ ;; URL: https://github.com/Malabarba/beacon ;; Keywords: convenience ;; Version: 0.1 -;; Package-Requires: ((cl-lib "0.5")) +;; Package-Requires: ((seq "1.9")) ;; 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 @@ -28,7 +28,7 @@ ;;; Code: -(require 'cl-lib) +(require 'seq) (defgroup beacon nil "Customization group for beacon." @@ -98,24 +98,35 @@ e.g. \"#666600\"." "Add an after-string property to OVERLAY. The property's value is a string of spaces with background COLORS applied to each one." - (overlay-put overlay 'beacon-colors colors) - (overlay-put overlay 'after-string - (mapconcat (lambda (c) (propertize " " 'face (list :background c))) - colors - ""))) + (if (not colors) + (delete-overlay overlay) + (overlay-put overlay 'beacon-colors colors) + (overlay-put overlay 'after-string + (propertize + (mapconcat (lambda (c) (propertize " " 'face (list :background c))) + colors + "") + 'cursor 1000)))) (defun beacon--after-string-overlay (colors) "Put an overlay at point with an after-string property. The property's value is a string of spaces with background COLORS applied to each one." - (let ((ov (make-overlay (point) (point)))) + (let ((ov (make-overlay (point) (point))) + ;; The after-string must not be longer than the remaining columns from + ;; point to right window-end else it will be wrapped around (assuming + ;; truncate-lines is nil) introducing an ugly wrap-around for a + ;; fraction of a second. + (colors (seq-take colors (- (window-width) (current-column))))) (beacon--ov-put-after-string ov colors) (overlay-put ov 'beacon t) (push ov beacon--ovs))) (defun beacon--ov-at-point () - (car (cl-member-if (lambda (o) (overlay-get o 'beacon)) - (overlays-at (point))))) + (car (or (seq-filter (lambda (o) (overlay-get o 'beacon)) + (overlays-in (point) (point))) + (seq-filter (lambda (o) (overlay-get o 'beacon)) + (overlays-at (point)))))) (defun beacon--vanish () "Turn off the beacon." @@ -164,19 +175,22 @@ Only returns `beacon-size' elements." (defun beacon--dec () "Decrease the beacon brightness by one." - (let ((o (beacon--ov-at-point))) - (if (not o) - (beacon--vanish) - (delete-overlay o) - (save-excursion - (while (progn (forward-char 1) - (setq o (beacon--ov-at-point))) - (let ((colors (overlay-get o 'beacon-colors))) - (if (not colors) - (move-overlay o (1- (point)) (point)) - (forward-char -1) - (beacon--colored-overlay (pop colors)) - (beacon--ov-put-after-string o colors)))))))) + (pcase (beacon--ov-at-point) + (`nil (beacon--vanish)) + ((and o (let c (overlay-get o 'beacon-colors)) (guard c)) + (beacon--ov-put-after-string o (cdr c))) + (o + (delete-overlay o) + (save-excursion + (while (progn (forward-char 1) + (setq o (beacon--ov-at-point))) + (let ((colors (overlay-get o 'beacon-colors))) + (if (not colors) + (move-overlay o (1- (point)) (point)) + (forward-char -1) + (beacon--colored-overlay (pop colors)) + (beacon--ov-put-after-string o colors) + (forward-char 1)))))))) (defun beacon-blink () "Blink the beacon at the position of the cursor." @@ -190,14 +204,15 @@ Only returns `beacon-size' elements." ;;; Movement detection +(defvar beacon--window-scrolled nil) (defvar beacon--previous-place nil) -(defvar beacon--previous-window-start nil) (defvar beacon--previous-mark-head nil) (defun beacon--movement-> (delta) "Return non-nil if latest point movement is > DELTA. If DELTA is nil, return nil." (and delta + (markerp beacon--previous-place) (equal (marker-buffer beacon--previous-place) (current-buffer)) (> (abs (- (point) beacon--previous-place)) @@ -228,9 +243,10 @@ If DELTA is nil, return nil." (beacon-blink)))) ;; Blink for scrolling. ((and beacon-blink-when-window-scrolls - (progn (redisplay) - (not (equal beacon--previous-window-start (window-start))))) - (beacon-blink)) + beacon--window-scrolled) + (with-selected-window beacon--window-scrolled + (beacon-blink)) + (setq beacon--window-scrolled nil)) ;; Blink for movement ((beacon--movement-> beacon-blink-when-point-moves) (beacon-blink)) @@ -238,16 +254,29 @@ If DELTA is nil, return nil." (t (beacon--vanish))) (beacon--maybe-push-mark) (unless (window-minibuffer-p) - (setq beacon--previous-window-start (window-start)) (setq beacon--previous-mark-head (car mark-ring)) (setq beacon--previous-place (point-marker)))) +(defun beacon--window-scroll-function (win _start-pos) + "Blink the beacon or record that window has been scrolled. +If invoked during the command loop, record the current window so +that it may be blinked on post-command. This is because the +scrolled window might not be active, but we only know that at +`post-command-hook'. + +If invoked outside the command loop, `post-command-hook' would be +unreliable, so just blink immediately." + (if this-command + (setq beacon--window-scrolled win) + (beacon-blink))) + ;;; Minor-mode -(defcustom beacon-lighter (cond - ((char-displayable-p ?💡) "💡") - ((char-displayable-p ?Λ) "Λ") - (t "*")) +(defcustom beacon-lighter + (cond + ((char-displayable-p ?💡) " 💡") + ((char-displayable-p ?Λ) " Λ") + (t " *")) "Lighter string used on the mode-line." :type 'string) @@ -256,7 +285,10 @@ If DELTA is nil, return nil." nil nil beacon-lighter nil :global t (if beacon-mode - (add-hook 'post-command-hook #'beacon--post-command) + (progn + (add-hook 'window-scroll-functions #'beacon--window-scroll-function) + (add-hook 'post-command-hook #'beacon--post-command)) + (remove-hook 'window-scroll-functions #'beacon--window-scroll-function) (remove-hook 'post-command-hook #'beacon--post-command))) (provide 'beacon)