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

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