-;;; on-screen.el --- guide your eyes while scrolling
+;;; on-screen.el --- guide your eyes while scrolling -*- lexical-binding: t -*-
-;; Copyright (C) 2013 Michael Heerdegen
+;; Copyright (C) 2013-2015 Free Software Foundation, Inc
;; Author: Michael Heerdegen <michael_heerdegen@web.de>
;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
;; Created: 24 Jan 2013
;; Keywords: convenience
-;; Version: 1.0
+;; URL: https://github.com/michael-heerdegen/on-screen.el
+;; Version: 1.3.2
+;; Package-Requires: ((cl-lib "0"))
;; This file is not part of GNU Emacs.
;; to enable it in all Info buffers.
;;
;; By default, fringe markers are used for highlighting - see
-;; `on-screen-highlight-method' to change that.
+;; `on-screen-highlight-method' to change that. Type M-x
+;; customize-group RET on-screen RET to see what else can be
+;; configured. If you use a configuration file (.emacs), you may also
+;; want to define mode specific settings by using buffer local
+;; variables. For example, to use non intrusive fringe markers by
+;; default, but transparent overlays in w3m, you would add
;;
-;; Type M-x customize-group RET on-screen RET to see what else can be
-;; configured.
+;; (add-hook
+;; 'w3m-mode-hook
+;; (defun my-w3m-setup-on-screen ()
+;; (setq-local on-screen-highlight-method 'shadow)))
;;
-;; If you want to use transparent overlays for highlighting, and there
-;; is the library "hexrgb.el" in your `load-path', it will be used to
-;; compute highlighting colors dynamically instead of using constant
-;; faces. I.e. if you use non-default background colors (e.g. from
-;; custom themes), on-screen will try to perform highlighting with a
+;; to your .emacs.
+;;
+;; If you use transparent overlays for highlighting and there is the
+;; library "hexrgb.el" in your `load-path', it will be used to compute
+;; highlighting colors dynamically instead of using constant faces.
+;; I.e. if you use non-default background colors (e.g. from custom
+;; themes), on-screen will try to perform highlighting with a
;; suitable, slightly different color. See
;; `on-screen-highlighting-to-background-delta' to control this.
;;
+;;
;; Implementation notes (mainly for myself):
;;
;; Implementing this functionality is not as straightforward as one
;;; Code:
-;;; Requirements
+;;;; Requirements
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl-lib))
(require 'timer)
(require 'hexrgb nil t)
+(declare-function hexrgb-saturation "hexrgb")
+(declare-function hexrgb-approx-equal "hexrgb")
+(declare-function hexrgb-increment-value "hexrgb")
+(declare-function hexrgb-increment-hue "hexrgb")
+
-;;; Configuration stuff
+;;;; Configuration stuff
(defgroup on-screen nil
"Guide your eyes while scrolling."
"What area to highlight.
When nil, highlight the previously visible screenful. Else
highlight the previously off-screen parts."
- :group 'on-screen :type 'boolean)
+ :type 'boolean)
(defcustom on-screen-highlight-method 'fringe
"Type of highlighting used by `on-screen-mode'.
(const :tag "Fringe markers" fringe)
(const :tag "Transparent overlay" shadow)
(const :tag "Overlay on confining text lines" line)
- (const :tag "Narrow horizontal line" narrow-line))
- :group 'on-screen)
+ (const :tag "Narrow horizontal line" narrow-line)))
(defcustom on-screen-fringe-marker-position t
"Where to display fringe markers.
:type '(choice
(const :tag "Left fringe only" left)
(const :tag "Right fringe only" right)
- (const :tag "Both sides" t))
- :group 'on-screen)
+ (const :tag "Both sides" t)))
(defface on-screen-shadow
- '((((class color grayscale) (min-colors 88) (background light))
- :background "gray95")
- (((class color grayscale) (min-colors 88) (background dark))
- :background "gray10")
- (((class color) (min-colors 8) (background light))
+ '((((class color) (min-colors 88) (background light))
+ :background "#f2efcb" ; alternative: "#f5f4ff" is a bit less intrusive
+ )
+ (((class color) (min-colors 88) (background dark))
+ :background "#272620")
+ (((class color) (min-colors 8) (background light))
:background "green")
- (((class color) (min-colors 8) (background dark))
+ (((class color) (min-colors 8) (background dark))
:background "blue"))
- "Face used for displaying a transparent overlay."
- :group 'on-screen)
+ "Face used for displaying a transparent overlay.")
+
+(defface on-screen-hl-line
+ '((((background light)) :background "#ffa0a0")
+ (((background dark)) :background "#300000"))
+ "Face used for displaying the \"line\" style overlay.")
(defcustom on-screen-highlighting-to-background-delta .05
"How much shadow and line highlighting should differ from background.
This variable is ignored if the library \"hexrgb\" is not
available."
- :group 'on-screen
:type '(choice (const :tag "Use standard face" nil)
(float :tag "Delta")))
(defface on-screen-fringe '((t (:inherit shadow)))
- "Face used for fringe markers."
- :group 'on-screen)
+ "Face used for fringe markers.")
-(defface on-screen-narrow-line '((t (:width extra-expanded
- :underline (:color "gray50" :style wave))))
- "Face used by the narrow-line highlighting method."
- :group 'on-screen)
+(defface on-screen-narrow-line
+ '((((background dark)) (:width extra-expanded :underline (:color "gray30" :style wave)))
+ (((background light)) (:width extra-expanded :underline (:color "gray70" :style wave))))
+ "Face used by the narrow-line highlighting method.")
(defcustom on-screen-delay 5
"How long `on-screen-mode' should display optical aids."
- :group 'on-screen :type 'number)
+ :type 'number)
(defcustom on-screen-auto-update t
"Whether to update highlighting for successive scrolls.
according to the previously visible screenful. When nil, a once
drawn highlighting will remain fixed relative to the text even
if you scroll further until `on-screen-delay' is over."
- :group 'on-screen :type 'boolean)
+ :type 'boolean)
+
+(defcustom on-screen-remove-when-edit nil
+ "Whether to instantly remove highlighting when editing.
+
+In those situations where a single command causes multiple
+changes to a buffer highlighting is always removed to avoid
+confusion."
+ :type 'boolean)
+
+(defvar on-screen-treat-cut-lines--default-fraction .3)
+
+(defcustom on-screen-treat-cut-lines nil
+ "Whether to care about vertically cut lines.
+If nil, always count lines at the window start or end that are
+only partially visible as part of the visible area. Else, a
+number between 0 and 1, meaning that lines will count as visible
+when the hidden part of them is less than this number. Note that
+a non-nil value may make scrolling stuttering on slow computers."
+ :type `(choice (const :tag "Count partially visible lines as visible" nil)
+ (const :tag "Count partially visible lines as not visible" t)
+ (float
+ :tag "Count lines with hidden part less than this as visible"
+ :value ,on-screen-treat-cut-lines--default-fraction)))
+
+(defcustom on-screen-drawing-threshold 2
+ "If set, highlight only when scrolled at least that many lines."
+ :type '(choice (const :tag "Off" nil)
+ (integer :value 2)))
+(defvar on-screen-inhibit-highlighting nil
+ "Disable highlighting if non-nil.
+This variable is checked before highlighting is actually being
+performed, with the according buffer being current.
-;;; Other variables
+If a function, it will be called with zero arguments.
+Highlighting will be inhibited if the result is non-nil.")
+
+
+;;;; Other variables
+
+(defvar on-screen-overlay-priority 30 ; > stripe buffer, < ediff, isearch
+ "Priority for all on-screen overlays.")
(defvar on-screen-initialized-p nil
"Whether we have already added stuff to the hooks.")
(defvar on-screen-data nil
"Association list holding internal data.")
+(defvar on-screen-command-counter 0)
+(defvar on-screen-last-change 0)
-;;; User Commands
+
+;;;; User Commands
;;;###autoload
(define-minor-mode on-screen-mode
With a prefix argument ARG, enable the mode if ARG is positive,
and disable it otherwise. If called from Lisp, enable the mode
if ARG is omitted or nil.
+
+You can make use of `on-screen-inhibit-highlighting' to prevent
+highlighting on a per-buffer basis.
+
Type M-x customize-group on-screen RET for configuration."
:group 'on-screen :global t
(when on-screen-global-mode
(unless on-screen-initialized-p
(on-screen-initialize))))
+;;;###autoload
(defalias 'global-on-screen-mode 'on-screen-global-mode)
-;;; Internal functions
+;;;; Internal functions
+
+(defun on-screen--treat-cut-lines-get-fraction ()
+ (if (floatp on-screen-treat-cut-lines)
+ on-screen-treat-cut-lines
+ on-screen-treat-cut-lines--default-fraction))
(defun on-screen-window-start (&optional window)
"Like `window-start', but exclude partially visible lines."
(let* ((start (window-start window))
- (vis (pos-visible-in-window-p start window t)))
+ (vis (and on-screen-treat-cut-lines (pos-visible-in-window-p start window t))))
(if (not (cddr vis))
start
- (destructuring-bind (_x _y rtop _rbot rowh _vpos) vis
- (if (< (/ (float rtop) (+ rtop rowh)) .4) ;; count as visible
+ (cl-destructuring-bind (_x _y rtop _rbot rowh _vpos) vis
+ (if (< (/ (float rtop) (+ rtop rowh))
+ (on-screen--treat-cut-lines-get-fraction)) ; count as visible
start
(with-current-buffer (window-buffer window)
(save-excursion
(defun on-screen-window-end (&optional window)
"Like `window-end', but exclude partially visible lines."
(let* ((end (window-end window))
- (vis (pos-visible-in-window-p (1- end) window t)))
+ (vis (and on-screen-treat-cut-lines (pos-visible-in-window-p (1- end) window t))))
(if (not (cddr vis))
end
- (destructuring-bind (_x _y _rtop rbot rowh _vpos) vis
- (if (< (/ (float rbot) (+ rbot rowh)) .4) ;; count as visible
+ (cl-destructuring-bind (_x _y _rtop rbot rowh _vpos) vis
+ (if (< (/ (float rbot) (+ rbot rowh))
+ (on-screen--treat-cut-lines-get-fraction)) ; count as visible
end
(with-current-buffer (window-buffer window)
(save-excursion
(on-screen-beginning-of-line 0)
(point))))))))
-(defalias 'on-screen-beginning-of-line
- (if (fboundp 'beginning-of-visual-line)
- 'beginning-of-visual-line
- 'beginning-of-line))
+(defun on-screen-beginning-of-line (&optional n)
+ (cl-callf or n 1)
+ (forward-visible-line (- n 1)))
-(defalias 'on-screen-end-of-line
- (if (fboundp 'end-of-visual-line)
- 'end-of-visual-line
- 'end-of-line))
+(defun on-screen-end-of-line (&optional n)
+ (cl-callf or n 1)
+ (forward-visible-line (- n 1))
+ (end-of-visible-line))
(defun on-screen-record-data (win area &optional timer overlays)
;; The collected data has the form ((beg end) timer overlays), and
(setq area (or area (and same-buffer-p (cadr data)))
timer (cond ((timerp timer) timer)
(timer nil)
- (t (and same-buffer-p (caddr data))))
- overlays (or overlays (and same-buffer-p (cadddr data)))
+ (t (and same-buffer-p (cl-caddr data))))
+ overlays (or overlays (and same-buffer-p (cl-cadddr data)))
data `(,(window-buffer win) ,area ,timer ,overlays))
(if entry
(setcdr entry data)
(defun on-screen-get-shadow-face (win)
"Return face for the transparent overlay in WIN."
- (or (and on-screen-highlighting-to-background-delta
- (let ((bg-col (apply #'on-screen-derive-from-frame-bg win
- (mapcar (lambda (x) (* x on-screen-highlighting-to-background-delta))
- (list 1 -1 1)))))
- (and bg-col `((t (:background ,bg-col))))))
- 'on-screen-shadow))
+ (if (eq on-screen-highlight-method 'shadow)
+ (or (and on-screen-highlighting-to-background-delta
+ (let ((bg-col (apply #'on-screen-derive-from-frame-bg win
+ (mapcar (lambda (x) (* x on-screen-highlighting-to-background-delta))
+ (list 1 -1 1)))))
+ (and bg-col `((t (:background ,bg-col))))))
+ 'on-screen-shadow)
+ 'on-screen-hl-line))
(defun on-screen-make-fringe-overlays (pos topp &optional inversep)
"Create and return list of fringe overlays."
(defun on-screen-fringe-string (topp leftp &optional inversep)
"Return a string suitable for displaying fringe markers."
(let ((xor (lambda (x y) (if x (not y) y))))
- (propertize (copy-sequence "on-screen")
+ (propertize (purecopy " ")
'display (list (if leftp 'left-fringe 'right-fringe)
(if (funcall xor topp (not inversep))
(if leftp 'top-left-angle 'top-right-angle)
(make-overlay (progn (goto-char pos) (on-screen-beginning-of-line) (point))
(progn (goto-char pos) (on-screen-end-of-line) (point))))))
(overlay-put ov 'face 'on-screen-narrow-line)
+ ;; The following is necessary to get a line spanning the entire
+ ;; window width, because underlining is only applied to text - a
+ ;; problem especially for empty lines. However this hides any
+ ;; other highlighting there, e.g. from stripe-buffer or
+ ;; hl-line-mode. I think there's nothing I can do about that.
(overlay-put ov 'after-string (propertize "foo"
'face 'on-screen-narrow-line
'display `(space :align-to ,(window-width win))
(mapcar (lambda (frame) (window-list frame))
(if all-frames (frame-list) (list (selected-frame))))))
-(defun on-screen-record-ranges (&optional all-frames)
- "Remember visible buffer parts.
-With ALL-FRAMES non-nil, include all windows of all live frames.
-Else, consider only the windows of the selected frame."
+(defun on-screen-pre-command ()
+ "Remember visible buffer parts in the selected frame."
;; This normally goes to `pre-command-hook'.
+ (cl-incf on-screen-command-counter)
+ (add-hook 'after-change-functions #'on-screen-after-change) ;$$$$ bug#16796
(condition-case nil
(mapc (lambda (win) (with-current-buffer (window-buffer win)
(when (on-screen-enabled-p)
(on-screen-record-data win (list (on-screen-window-start win)
(on-screen-window-end win))))))
- (on-screen-get-windows all-frames))
+ (on-screen-get-windows))
((debug error) nil)))
(defun on-screen-after-scroll (win display-start)
(let* ((win-data (on-screen-get-data win))
(area (car win-data))
(timer (cadr win-data))
- (overlays (caddr win-data))
+ (overlays (cl-caddr win-data))
(s1 (car area))
(s2 (cadr area)))
- (when (and on-screen-auto-update (timerp timer))
+ (when (and
+ on-screen-auto-update
+ (timerp timer)
+ ;; avoid removing highlighting when `window-scroll-functions' is
+ ;; called multiple times in succession (follow-mode does that)
+ (not (eq (car-safe area) (on-screen-window-start win))))
;; do what the timer would do, and cancel timer
(on-screen-remove-highlighting win)
(cancel-timer timer)
(timer-set-time timer (timer-relative-time (current-time) on-screen-delay)))
((or (not area)
(= display-start s1)))
+ ((and (numberp on-screen-drawing-threshold)
+ (< (abs (apply #'count-lines (sort (list display-start s1) #'<)))
+ on-screen-drawing-threshold)))
(t
(setq
overlays
(pos-visible-in-window-p (point-max) win))
;; after narrow
(setq s1 nil s2 nil))
-
+
(when (and s1 s2
(>= s2 (point-max))
(< s1 (on-screen-window-start win))
overlays (delq nil overlays))
(dolist (ov overlays)
(overlay-put ov 'window win) ; display only in selected window
- (overlay-put ov 'priority 9999))
+ (overlay-put ov 'priority on-screen-overlay-priority))
(when (memq on-screen-highlight-method '(shadow line))
(dolist (ov overlays)
(overlay-put ov 'face (on-screen-get-shadow-face win))))
(with-current-buffer buffer
(let* ((data (cdr data))
(timer (cadr data))
- (overlays (caddr data)))
+ (overlays (cl-caddr data)))
(dolist (ov overlays) (delete-overlay ov))
(when (timerp timer) (cancel-timer timer))))
(setq on-screen-data (delq entry on-screen-data)))))
-(defun on-screen-reset (&rest _)
+(defun on-screen-after-change (&rest _)
"Reset highligting for current buffer after it was changed.
This has to be done for all its windows. Goes to
`after-change-functions'."
- (let ((buf (current-buffer)))
- (when (on-screen-enabled-p buf)
- (dolist (win (on-screen-get-windows t))
- (when (eq (window-buffer win) buf)
- (on-screen-remove-highlighting win))))))
+ (when (or on-screen-remove-when-edit
+ (= on-screen-last-change on-screen-command-counter))
+ (let ((buf (current-buffer)))
+ (when (on-screen-enabled-p buf)
+ (dolist (win (on-screen-get-windows t))
+ (when (eq (window-buffer win) buf)
+ (on-screen-remove-highlighting win))))))
+ (setq on-screen-last-change on-screen-command-counter))
(defun on-screen-after-wconf-change ()
"Clean up after the window configuration has changed.
(defun on-screen-enabled-p (&optional buffer)
"Return non-nil if on-screen is enabled in BUFFER."
(with-current-buffer (or buffer (current-buffer))
- (if on-screen-global-mode t on-screen-mode)))
+ (and
+ (or on-screen-global-mode on-screen-mode)
+ (cond
+ ((not on-screen-inhibit-highlighting) t)
+ ((functionp on-screen-inhibit-highlighting)
+ (not (funcall on-screen-inhibit-highlighting)))
+ (t nil)))))
(defun on-screen-initialize ()
"Prepare for using on-screen."
- (add-hook 'pre-command-hook #'on-screen-record-ranges)
+ (add-hook 'pre-command-hook #'on-screen-pre-command)
(add-hook 'window-scroll-functions #'on-screen-after-scroll)
- (add-hook 'after-change-functions #'on-screen-reset)
+ (add-hook 'after-change-functions #'on-screen-after-change)
(add-hook 'window-configuration-change-hook #'on-screen-after-wconf-change)
(setq on-screen-initialized-p t))
+(defun on-screen-unload-function ()
+ "Function to run when unloading on-screen."
+ (remove-hook 'pre-command-hook #'on-screen-pre-command)
+ (remove-hook 'window-scroll-functions #'on-screen-after-scroll)
+ (remove-hook 'after-change-functions #'on-screen-after-change)
+ (remove-hook 'window-configuration-change-hook #'on-screen-after-wconf-change)
+ nil)
+
(provide 'on-screen)