code.delx.au - gnu-emacs-elpa/blob - on-screen.el

   1 ;;; on-screen.el --- guide your eyes while scrolling
   2
   3 ;; Copyright (C) 2013 Michael Heerdegen
   4
   5 ;; Author: Michael Heerdegen <michael_heerdegen@web.de>
   6 ;; Maintainer: Michael Heerdegen <michael_heerdegen@web.de>
   7 ;; Created: 24 Jan 2013
   8 ;; Keywords: convenience
   9 ;; Version: 1.0
  10
  11
  12 ;; This file is not part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27
  28 ;;; Commentary:
  29
  30 ;; Scrolling can be distracting because your eyes may lose
  31 ;; orientation.  This library implements a minor mode that highlights
  32 ;; the previously visible buffer part after each scroll.
  33 ;;
  34 ;; Installation: Put this library somewhere in your load-path, or
  35 ;; install via M-x package-list-packages.  Then add to your init-file:
  36 ;;
  37 ;;   (require 'on-screen)
  38 ;;
  39 ;; To invoke on-screen globally for all buffers, also add
  40 ;;
  41 ;;   (on-screen-global-mode +1)
  42 ;;
  43 ;; Alternatively you can use the buffer local version `on-screen-mode'.
  44 ;; For example, add this line to your init file:
  45 ;;
  46 ;;   (add-hook 'Info-mode-hook 'on-screen-mode)
  47 ;;
  48 ;; to enable it in all Info buffers.
  49 ;;
  50 ;; By default, fringe markers are used for highlighting - see
  51 ;; `on-screen-highlight-method' to change that.
  52 ;;
  53 ;; Type M-x customize-group RET on-screen RET to see what else can be
  54 ;; configured.
  55 ;;
  56 ;; If you want to use transparent overlays for highlighting, and there
  57 ;; is the library "hexrgb.el" in your `load-path', it will be used to
  58 ;; compute highlighting colors dynamically instead of using constant
  59 ;; faces.  I.e. if you use non-default background colors (e.g. from
  60 ;; custom themes), on-screen will try to perform highlighting with a
  61 ;; suitable, slightly different color.  See
  62 ;; `on-screen-highlighting-to-background-delta' to control this.
  63 ;;
  64 ;; Implementation notes (mainly for myself):
  65 ;;
  66 ;; Implementing this functionality is not as straightforward as one
  67 ;; might think.  There are commands that scroll other windows than the
  68 ;; current one.  Not only scrolling commands can scroll text - also
  69 ;; editing or even redisplay can cause windows to scroll.  There is
  70 ;; weird stuff such as folding and narrowing, influencing the visible
  71 ;; buffer part.  And although highlighting is realized in the
  72 ;; displayed buffers (with overlays), it must be organized on a
  73 ;; per-window basis, because different buffer parts may be displayed
  74 ;; in different windows, and their highlightings must not interfere.
  75 ;;
  76 ;; That all makes it necessary to observe windows via hacks in
  77 ;; different hooks, and to manage information about buffers, visible
  78 ;; parts and timers in a data structure (`on-screen-data').  It is
  79 ;; realized as an association list whose keys are windows.  There are
  80 ;; some pitfalls - e.g. the data can be out of date if the window
  81 ;; configuration has changed and windows display different buffers
  82 ;; now.  The data must be updated, but not simply be thrown away,
  83 ;; because the highlightings in the old buffers must be removed
  84 ;; nonetheless.
  85 ;;
  86 ;;
  87 ;; Acknowledgments:
  88 ;;
  89 ;; This library was inspired by a similar feature of the "Conqueror"
  90 ;; web browser.
  91 ;;
  92 ;; Thanks for Drew Adams for testing and contributions.
  93
  94
  95
  96
  97 ;;; Code:
  98
  99 ;;; Requirements
 100
 101 (eval-when-compile (require 'cl))
 102 (require 'timer)
 103 (require 'hexrgb nil t)
 104
 105
 106 ;;; Configuration stuff
 107
 108 (defgroup on-screen nil
 109   "Guide your eyes while scrolling."
 110   :group 'convenience
 111   :prefix "on-screen")
 112
 113 (defcustom on-screen-inverse-flag nil
 114   "What area to highlight.
 115 When nil, highlight the previously visible screenful.  Else
 116 highlight the previously off-screen parts."
 117   :group 'on-screen :type 'boolean)
 118
 119 (defcustom on-screen-highlight-method 'fringe
 120   "Type of highlighting used by `on-screen-mode'.
 121 The following values are valid:
 122
 123   fringe       - graphical markers in the fringe
 124   shadow       - transparent overlay on the text
 125   line         - transparent overlay on the confining text lines
 126   narrow-line  - narrow horizontal lines
 127
 128 The fringe and the narrow-line methods only work on graphical
 129 displays.  narrow-line only works with Emacs 24 or higher.
 130
 131 `on-screen-inverse-flag' defines which part(s) of the buffers are
 132 highlighted.
 133
 134 The face used for \"shadow\" and \"line\" may be computed
 135 dynamically to support different background colors (color themes)
 136 - see `on-screen-highlighting-to-background-delta'."
 137   :type '(choice
 138           (const :tag "Fringe markers"                     fringe)
 139           (const :tag "Transparent overlay"                shadow)
 140           (const :tag "Overlay on confining text lines"    line)
 141           (const :tag "Narrow horizontal line"             narrow-line))
 142   :group 'on-screen)
 143
 144 (defcustom on-screen-fringe-marker-position t
 145   "Where to display fringe markers.
 146 Ignored if highlighting doesn't use the fringe."
 147   :type '(choice
 148           (const :tag "Left fringe only"  left)
 149           (const :tag "Right fringe only" right)
 150           (const :tag "Both sides"        t))
 151   :group 'on-screen)
 152
 153 (defface on-screen-shadow
 154   '((((class color grayscale) (min-colors 88) (background light))
 155      :background "gray95")
 156     (((class color grayscale) (min-colors 88) (background dark))
 157      :background "gray10")
 158     (((class color) (min-colors 8) (background light))
 159      :background "green")
 160     (((class color) (min-colors 8) (background dark))
 161      :background "blue"))
 162   "Face used for displaying a transparent overlay."
 163   :group 'on-screen)
 164
 165 (defcustom on-screen-highlighting-to-background-delta .05
 166   "How much shadow and line highlighting should differ from background.
 167 This should be a positive floating point number less than 1.
 168 Smaller values will lead to a highlighting color being more
 169 similar to the frame background.  A value of nil means to use use
 170 just face `on-screen-shadow'.
 171
 172 This variable is ignored if the library \"hexrgb\" is not
 173 available."
 174   :group 'on-screen
 175   :type '(choice (const :tag "Use standard face" nil)
 176                  (float :tag "Delta")))
 177
 178 (defface on-screen-fringe '((t (:inherit shadow)))
 179   "Face used for fringe markers."
 180   :group 'on-screen)
 181
 182 (defface on-screen-narrow-line '((t (:width extra-expanded
 183                                      :underline (:color "gray50" :style wave))))
 184   "Face used by the narrow-line highlighting method."
 185   :group 'on-screen)
 186
 187 (defcustom on-screen-delay 5
 188   "How long `on-screen-mode' should display optical aids."
 189   :group 'on-screen :type 'number)
 190
 191 (defcustom on-screen-auto-update t
 192   "Whether to update highlighting for successive scrolls.
 193 When non-nil, every scroll action will cause a highlighting
 194 according to the previously visible screenful.  When nil, a once
 195 drawn highlighting will remain fixed relative to the text even
 196 if you scroll further until `on-screen-delay' is over."
 197   :group 'on-screen :type 'boolean)
 198
 199
 200 ;;; Other variables
 201
 202 (defvar on-screen-initialized-p nil
 203   "Whether we have already added stuff to the hooks.")
 204
 205 (defvar on-screen-data nil
 206   "Association list holding internal data.")
 207
 208
 209 ;;; User Commands
 210
 211 ;;;###autoload
 212 (define-minor-mode on-screen-mode
 213   "Buffer local minor mode guiding your eyes while scrolling.
 214 With a prefix argument ARG, enable the mode if ARG is positive,
 215 and disable it otherwise.  If called from Lisp, enable the mode
 216 if ARG is omitted or nil.
 217 Type M-x customize-group on-screen RET for configuration."
 218   :group 'on-screen
 219   (when on-screen-mode
 220     (unless on-screen-initialized-p
 221       (on-screen-initialize))))
 222
 223 ;;;###autoload
 224 (define-minor-mode on-screen-global-mode
 225   "Global minor mode guiding your eyes while scrolling.
 226 With a prefix argument ARG, enable the mode if ARG is positive,
 227 and disable it otherwise.  If called from Lisp, enable the mode
 228 if ARG is omitted or nil.
 229 Type M-x customize-group on-screen RET for configuration."
 230   :group 'on-screen :global t
 231   (when on-screen-global-mode
 232     (unless on-screen-initialized-p
 233       (on-screen-initialize))))
 234
 235 (defalias 'global-on-screen-mode 'on-screen-global-mode)
 236
 237
 238 ;;; Internal functions
 239
 240 (defun on-screen-window-start (&optional window)
 241   "Like `window-start', but exclude partially visible lines."
 242   (let* ((start (window-start window))
 243          (vis (pos-visible-in-window-p start window t)))
 244     (if (not (cddr vis))
 245         start
 246       (destructuring-bind (_x _y rtop _rbot rowh _vpos) vis
 247         (if (< (/ (float rtop) (+ rtop rowh)) .4) ;; count as visible
 248             start
 249           (with-current-buffer (window-buffer window)
 250             (save-excursion
 251               (goto-char start)
 252               (on-screen-beginning-of-line +2)
 253               (point))))))))
 254
 255 (defun on-screen-window-end (&optional window)
 256   "Like `window-end', but exclude partially visible lines."
 257   (let* ((end (window-end window))
 258          (vis (pos-visible-in-window-p (1- end) window t)))
 259     (if (not (cddr vis))
 260         end
 261       (destructuring-bind (_x _y _rtop rbot rowh _vpos) vis
 262         (if (< (/ (float rbot) (+ rbot rowh)) .4) ;; count as visible
 263             end
 264           (with-current-buffer (window-buffer window)
 265             (save-excursion
 266               (goto-char end)
 267               (on-screen-beginning-of-line 0)
 268               (point))))))))
 269
 270 (defalias 'on-screen-beginning-of-line
 271   (if (fboundp 'beginning-of-visual-line)
 272       'beginning-of-visual-line
 273     'beginning-of-line))
 274
 275 (defalias 'on-screen-end-of-line
 276   (if (fboundp 'end-of-visual-line)
 277       'end-of-visual-line
 278     'end-of-line))
 279
 280 (defun on-screen-record-data (win area &optional timer overlays)
 281   ;; The collected data has the form ((beg end) timer overlays), and
 282   ;; this is what `on-screen-get-data' returns.  Internally, this
 283   ;; function also remembers the window-buffer of the window, to
 284   ;; enable the mode to check if remembered data still belongs to the
 285   ;; same buffer.
 286   "Store information for window WIN in `on-screen-data'.
 287 AREA is a list (beg end).  TIMER is the currently active timer
 288 object.  OVERLAYS are the on-screen overlays currently visible in
 289 WIN.
 290
 291 A nil value for AREA, TIMER or OVERLAYS means that the remembered
 292 values should not be changed.  If TIMER is the symbol `finished',
 293 remember nil for the timer."
 294   (let* ((entry (assoc win on-screen-data))
 295          (data  (cdr entry))
 296          (same-buffer-p (eq (car data) (window-buffer win))))
 297     (setq area  (or area        (and same-buffer-p (cadr data)))
 298           timer (cond  ((timerp timer) timer)
 299                        (timer nil)
 300                        (t (and same-buffer-p (caddr data))))
 301           overlays (or overlays (and same-buffer-p (cadddr data)))
 302           data  `(,(window-buffer win) ,area ,timer ,overlays))
 303     (if entry
 304         (setcdr entry data)
 305       (push (cons win data) on-screen-data))))
 306
 307 (defun on-screen-get-data (win)
 308   "Return stored data for WIN if existent and up-to-date."
 309   (let ((data (cdr (assoc win on-screen-data))))
 310     (if (eq (car data) (window-buffer win))
 311         (cdr data)
 312       nil)))
 313
 314 (defun on-screen-cleanup-data ()
 315   "Delete information stored for deleted windows."
 316   (setq on-screen-data
 317         (delq nil (mapcar (lambda (entry) (if (window-live-p (car entry)) entry nil))
 318                           on-screen-data))))
 319
 320 (defun on-screen-derive-from-frame-bg
 321   (win delta-brightness-dark-bg delta-brightness-light-bg delta-hue)
 322   "Helper calculating a suitable background color for highlighting."
 323   (let ((frame (window-frame win)))
 324     (and (display-graphic-p frame) (featurep 'hexrgb)
 325          (let* ((bg (or (let ((frame-bg  (cdr (assq 'background-color (frame-parameters frame)))))
 326                           (when (member frame-bg '(nil unspecified "unspecified-bg"))
 327                             (setq frame-bg  (if (eq (frame-parameter frame 'background-mode) 'dark)
 328                                                 "Black"
 329                                               "White")))
 330                           (and frame-bg  (x-color-defined-p frame-bg)  frame-bg))))
 331                 (sat (condition-case nil (hexrgb-saturation bg) (error nil))))
 332            (and sat
 333                 (if (hexrgb-approx-equal sat 0.0)
 334                     ;; Grayscale - change bg value slightly.
 335                     (hexrgb-increment-value
 336                      bg (if (eq (frame-parameter frame 'background-mode) 'dark)
 337                             delta-brightness-dark-bg
 338                           delta-brightness-light-bg))
 339                   (hexrgb-increment-hue bg delta-hue)) ; Color - change bg hue slightly.
 340                 )))))
 341
 342 (defun on-screen-get-shadow-face (win)
 343   "Return face for the transparent overlay in WIN."
 344   (or (and on-screen-highlighting-to-background-delta
 345            (let ((bg-col (apply #'on-screen-derive-from-frame-bg win
 346                                 (mapcar (lambda (x) (* x on-screen-highlighting-to-background-delta))
 347                                         (list 1 -1 1)))))
 348              (and bg-col `((t (:background ,bg-col))))))
 349       'on-screen-shadow))
 350
 351 (defun on-screen-make-fringe-overlays (pos topp &optional inversep)
 352   "Create and return list of fringe overlays."
 353   (let (ov1 ov2)
 354     (unless (eq on-screen-fringe-marker-position 'left)
 355       (setq ov1  (save-excursion (make-overlay (progn (goto-char pos)
 356                                                       (on-screen-beginning-of-line
 357                                                        (cond ((not inversep) +1)
 358                                                              (topp           +2)
 359                                                              (t               0)))
 360                                                       (point))
 361                                                (1+ (point)))))
 362       (overlay-put ov1 'before-string (on-screen-fringe-string topp nil inversep)))
 363     (unless (eq on-screen-fringe-marker-position 'right)
 364       (setq ov2  (save-excursion (make-overlay (progn (goto-char pos)
 365                                                       (on-screen-beginning-of-line
 366                                                        (cond ((not inversep) +1)
 367                                                              (topp           +2)
 368                                                              (t               0)))
 369                                                       (point))
 370                                                (1+ (point)))))
 371       (overlay-put ov2 'before-string (on-screen-fringe-string topp t inversep)))
 372     (delq nil (list ov1 ov2))))
 373
 374 (defun on-screen-fringe-string (topp leftp &optional inversep)
 375   "Return a string suitable for displaying fringe markers."
 376   (let ((xor (lambda (x y) (if x (not y) y))))
 377     (propertize (copy-sequence "on-screen")
 378                 'display  (list (if leftp 'left-fringe 'right-fringe)
 379                                 (if (funcall xor topp (not inversep))
 380                                     (if leftp 'top-left-angle 'top-right-angle)
 381                                   (if leftp 'bottom-left-angle 'bottom-right-angle))
 382                                 'on-screen-fringe))))
 383
 384 (defun on-screen-make-line-overlay (pos)
 385   "Create an overlay around POS for the line method."
 386   (save-excursion
 387     (make-overlay (progn (goto-char pos) (on-screen-beginning-of-line)     (point))
 388                   (progn (goto-char pos) (on-screen-end-of-line)       (1+ (point))))))
 389
 390 (defun on-screen-make-narrow-line-overlay (win pos)
 391   "Create an overlay around POS for the narrow-line method."
 392   (let ((ov (save-excursion
 393               (make-overlay (progn (goto-char pos) (on-screen-beginning-of-line) (point))
 394                             (progn (goto-char pos) (on-screen-end-of-line)       (point))))))
 395     (overlay-put ov 'face 'on-screen-narrow-line)
 396     (overlay-put ov 'after-string (propertize "foo"
 397                                               'face 'on-screen-narrow-line
 398                                               'display `(space :align-to ,(window-width win))
 399                                               'cursor 0))
 400     ov))
 401
 402 (defun on-screen-get-windows (&optional all-frames)
 403   "Return a list of all windows.
 404 With ALL-FRAMES non-nil, include all windows of all frames, else
 405 only the windows of the selected frame."
 406   (apply #'nconc
 407          (mapcar (lambda (frame) (window-list frame))
 408                  (if all-frames (frame-list) (list (selected-frame))))))
 409
 410 (defun on-screen-record-ranges ()
 411   "Remember visible buffer parts in the selected frame."
 412   ;;   This normally goes to `pre-command-hook'.
 413   (condition-case nil
 414       (mapc (lambda (win) (with-current-buffer (window-buffer win)
 415                        (when (on-screen-enabled-p)
 416                          (on-screen-record-data win (list (on-screen-window-start win)
 417                                                           (on-screen-window-end   win))))))
 418             (on-screen-get-windows))
 419     ((debug error) nil)))
 420
 421 (defun on-screen-after-scroll (win display-start)
 422   "DTRT after scrolling.
 423 This should normally go to `window-scroll-functions'."
 424   (condition-case nil
 425       (with-current-buffer (window-buffer win)
 426         (when (on-screen-enabled-p)
 427           (let* ((win-data (on-screen-get-data win))
 428                  (area     (car  win-data))
 429                  (timer    (cadr win-data))
 430                  (overlays (caddr win-data))
 431                  (s1       (car area))
 432                  (s2       (cadr area)))
 433             (when (and on-screen-auto-update (timerp timer))
 434               ;; do what the timer would do, and cancel timer
 435               (on-screen-remove-highlighting win)
 436               (cancel-timer timer)
 437               (on-screen-record-data win area 'finished)
 438               (setq timer nil))
 439             (cond
 440              ((timerp timer)
 441               (timer-set-time timer (timer-relative-time (current-time) on-screen-delay)))
 442              ((or (not area)
 443                   (= display-start s1)))
 444              (t
 445               (setq
 446                overlays
 447                (let ((method `(,on-screen-highlight-method . ,on-screen-inverse-flag)))
 448
 449                  ;; prevent highlighting in certain situations
 450                  ;; note that `window-end' must not be used here!
 451
 452                  (when (and s1 s2
 453                             (pos-visible-in-window-p (point-min) win)
 454                             (pos-visible-in-window-p (point-max) win))
 455                    ;; after narrow
 456                    (setq s1 nil s2 nil))
 457
 458                  (when (and s1 s2
 459                             (>= s2 (point-max))
 460                             (< s1 (on-screen-window-start win))
 461                             (pos-visible-in-window-p (point-max) win))
 462                    ;;scrolling down near buffer end
 463                    (setq s2 nil))
 464
 465                  (cond
 466                   ((equal method '(shadow . nil))
 467                    (if (and s1 s2) (list (make-overlay s1 s2)) ()))
 468                   ((eq (car method) 'shadow)
 469                    (list (and s1 (make-overlay (point-min)  s1))
 470                          (and s2 (make-overlay          s2  (point-max)))))
 471                   ((eq (car method) 'fringe)
 472                    (append (and s1 (on-screen-make-fringe-overlays     s1  nil (cdr method)))
 473                            (and s2 (on-screen-make-fringe-overlays (1- s2)   t (cdr method)))))
 474                   ((equal method '(line . nil))
 475                    (list (and s1 (on-screen-make-line-overlay     s1))
 476                          (and s2 (on-screen-make-line-overlay (1- s2)))))
 477                   ((eq (car method) 'line)
 478                    (list (and s1 (on-screen-make-line-overlay (1- s1)))
 479                          (and s2 (on-screen-make-line-overlay     s2))))
 480                   ((eq (car method) 'narrow-line)
 481                    (list (and s1 (on-screen-make-narrow-line-overlay win (1- s1)))
 482                          (and s2 (on-screen-make-narrow-line-overlay win (1- s2)))))))
 483                overlays (delq nil overlays))
 484               (dolist (ov overlays)
 485                 (overlay-put ov 'window win) ; display only in selected window
 486                 (overlay-put ov 'priority 9999))
 487               (when (memq on-screen-highlight-method '(shadow line))
 488                 (dolist (ov overlays)
 489                   (overlay-put ov 'face (on-screen-get-shadow-face win))))
 490               (on-screen-record-data
 491                win nil
 492                (run-at-time (time-add (current-time) (seconds-to-time on-screen-delay)) nil
 493                             (lambda (win)
 494                               (condition-case nil
 495                                   (progn
 496                                     (when (window-live-p win)
 497                                       (with-current-buffer (window-buffer win)
 498                                         (on-screen-remove-highlighting win)
 499                                         (on-screen-record-data
 500                                          win (list (on-screen-window-start win)
 501                                                    (on-screen-window-end win))
 502                                          'finished)))
 503                                     (on-screen-cleanup-data))
 504                                 ((debug error) nil)))
 505                             win)
 506                overlays))))))
 507     ((debug error) nil)))
 508
 509 (defun on-screen-remove-highlighting (win)
 510   "Delete all on-screen overlays in window WIN.
 511 This has to be done for a previously buffer if the window-buffer
 512 had changed."
 513   (let* ((entry (assoc win on-screen-data))
 514          (data  (cdr entry))
 515          (buffer (car data)))
 516     (when (buffer-live-p buffer)
 517       (with-current-buffer buffer
 518         (let* ((data     (cdr data))
 519                (timer    (cadr data))
 520                (overlays (caddr data)))
 521           (dolist (ov overlays) (delete-overlay ov))
 522           (when (timerp timer) (cancel-timer timer))))
 523       (setq on-screen-data (delq entry on-screen-data)))))
 524
 525 (defun on-screen-reset (&rest _)
 526   "Reset highligting for current buffer after it was changed.
 527 This has to be done for all its windows.  Goes to
 528 `after-change-functions'."
 529   (let ((buf (current-buffer)))
 530     (when (on-screen-enabled-p buf)
 531       (dolist (win (on-screen-get-windows t))
 532         (when (eq (window-buffer win) buf)
 533           (on-screen-remove-highlighting win))))))
 534
 535 (defun on-screen-after-wconf-change ()
 536   "Clean up after the window configuration has changed.
 537 I.e., for all windows of the selected frame, remove all
 538 highlightings and clear all associated data."
 539   (let ((wins (on-screen-get-windows)))
 540     (dolist (win wins)
 541       (on-screen-remove-highlighting win))))
 542
 543 (defun on-screen-enabled-p (&optional buffer)
 544   "Return non-nil if on-screen is enabled in BUFFER."
 545   (with-current-buffer (or buffer (current-buffer))
 546     (if on-screen-global-mode t on-screen-mode)))
 547
 548 (defun on-screen-initialize ()
 549   "Prepare for using on-screen."
 550   (add-hook 'pre-command-hook        #'on-screen-record-ranges)
 551   (add-hook 'window-scroll-functions #'on-screen-after-scroll)
 552   (add-hook 'after-change-functions  #'on-screen-reset)
 553   (add-hook 'window-configuration-change-hook #'on-screen-after-wconf-change)
 554   (setq on-screen-initialized-p t))
 555
 556
 557 (provide 'on-screen)
 558
 559 ;;; on-screen.el ends here