lisp/emacs-lisp/cursor-sensor.el

   1 ;;; cursor-sensor.el --- React to cursor movement  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords:
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This package implements the `cursor-intangible' property, which is
  26 ;; meant to replace the old `intangible' property.  To use it, just enable the
  27 ;; `cursor-intangible-mode', after which this package will move point away from
  28 ;; any position that has a non-nil `cursor-intangible' property.  This is only
  29 ;; done just before redisplay happens, contrary to the old `intangible'
  30 ;; property which was done at a much lower level.
  31
  32 ;;; Code:
  33
  34 ;;;###autoload
  35 (defvar cursor-sensor-inhibit nil)
  36
  37 (defun cursor-sensor--intangible-p (pos)
  38   (let ((p (get-pos-property pos 'cursor-intangible)))
  39     (if p
  40         (let (a b)
  41           (if (and (setq a (get-char-property pos 'cursor-intangible))
  42                    (setq b (if (> pos (point-min))
  43                                (get-char-property (1- pos) 'cursor-intangible)))
  44                    (not (eq a b)))
  45               ;; If we're right between two different intangible thingies,
  46               ;; we can stop here.  This is not quite consistent with the
  47               ;; interpretation of "if it's sticky, then this boundary is
  48               ;; itself intangible", but it's convenient (and it better matches
  49               ;; the behavior of `intangible', making it easier to port code).
  50               nil p))
  51       p)))
  52
  53 (defun cursor-sensor-tangible-pos (curpos window &optional second-chance)
  54   (let ((newpos curpos))
  55     (when (cursor-sensor--intangible-p newpos)
  56       (let ((oldpos (window-parameter window 'cursor-intangible--last-point)))
  57         (cond
  58          ((or (and (integerp oldpos) (< oldpos newpos))
  59               (eq newpos (point-min)))
  60           (while
  61               (when (< newpos (point-max))
  62                 (setq newpos
  63                       (if (get-char-property newpos 'cursor-intangible)
  64                           (next-single-char-property-change
  65                            newpos 'cursor-intangible nil (point-max))
  66                         (1+ newpos)))
  67                 (cursor-sensor--intangible-p newpos))))
  68          (t ;; (>= oldpos newpos)
  69           (while
  70               (when (> newpos (point-min))
  71                 (setq newpos
  72                       (if (get-char-property (1- newpos) 'cursor-intangible)
  73                           (previous-single-char-property-change
  74                            newpos 'cursor-intangible nil (point-min))
  75                         (1- newpos)))
  76                 (cursor-sensor--intangible-p newpos)))))
  77         (if (not (and (or (eq newpos (point-min)) (eq newpos (point-max)))
  78                       (cursor-sensor--intangible-p newpos)))
  79             ;; All clear, we're good to go.
  80             newpos
  81           ;; We're still on an intangible position because we bumped
  82           ;; into an intangible BOB/EOB: try to move in the other direction.
  83           (if second-chance
  84               ;; Actually, we tried already and that failed!
  85               curpos
  86             (cursor-sensor-tangible-pos newpos window 'second-chance)))))))
  87
  88 (defun cursor-sensor-move-to-tangible (window)
  89   (let* ((curpos (window-point window))
  90          (newpos (cursor-sensor-tangible-pos curpos window)))
  91     (when newpos (set-window-point window newpos))
  92     (set-window-parameter window 'cursor-intangible--last-point
  93                           (or newpos curpos))))
  94
  95 (defun cursor-sensor--move-to-tangible (window)
  96   (unless cursor-sensor-inhibit
  97     (cursor-sensor-move-to-tangible window)))
  98
  99 ;;;###autoload
 100 (define-minor-mode cursor-intangible-mode
 101   "Keep cursor outside of any `cursor-intangible' text property."
 102   nil nil nil
 103   (if cursor-intangible-mode
 104       (add-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible
 105                 nil t)
 106     (remove-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible t)))
 107
 108 ;;; Detect cursor movement.
 109
 110 (defun cursor-sensor--detect (window)
 111   (unless cursor-sensor-inhibit
 112     (let* ((point (window-point window))
 113            ;; It's often desirable to make the cursor-sensor-functions property
 114            ;; non-sticky on both ends, but that means get-pos-property might
 115            ;; never see it.
 116            (new (or (get-char-property point 'cursor-sensor-functions)
 117                     (unless (<= (point-min) point)
 118                       (get-char-property (1- point) 'cursor-sensor-functions))))
 119            (old (window-parameter window 'cursor-sensor--last-state))
 120            (oldposmark (car old))
 121            (oldpos (or (if oldposmark (marker-position oldposmark))
 122                        (point-min)))
 123            (start (min oldpos point))
 124            (end (max oldpos point)))
 125       (unless (or (null old) (eq (marker-buffer oldposmark) (current-buffer)))
 126         ;; `window' does not display the same buffer any more!
 127         (setcdr old nil))
 128       (if (or (and (null new) (null (cdr old)))
 129               (and (eq new (cdr old))
 130                    (eq (next-single-property-change
 131                         start 'cursor-sensor-functions nil end)
 132                        end)))
 133           ;; Clearly nothing to do.
 134           nil
 135         ;; Maybe something to do.  Let's see exactly what needs to run.
 136         (let* ((missing-p
 137                 (lambda (f)
 138                   "Non-nil if F is missing somewhere between START and END."
 139                   (let ((pos start)
 140                         (missing nil))
 141                     (while (< pos end)
 142                       (setq pos (next-single-property-change
 143                                  pos 'cursor-sensor-functions
 144                                  nil end))
 145                       (unless (memq f (get-char-property
 146                                        pos 'cursor-sensor-functions))
 147                         (setq missing t)))
 148                     missing))))
 149           (dolist (f (cdr old))
 150             (unless (and (memq f new) (not (funcall missing-p f)))
 151               (funcall f window oldpos 'left)))
 152           (dolist (f new)
 153             (unless (and (memq f (cdr old)) (not (funcall missing-p f)))
 154               (funcall f window oldpos 'entered)))))
 155
 156       ;; Remember current state for next time.
 157       ;; Re-read cursor-sensor-functions since the functions may have moved
 158       ;; window-point!
 159       (if old
 160           (progn (move-marker (car old) point)
 161                  (setcdr old new))
 162         (set-window-parameter window 'cursor-sensor--last-state
 163                               (cons (copy-marker point) new))))))
 164
 165 ;;;###autoload
 166 (define-minor-mode cursor-sensor-mode
 167   "Handle the `cursor-sensor-functions' text property.
 168 This property should hold a list of functions which react to the motion
 169 of the cursor.  They're called with three arguments (WINDOW OLDPOS DIR)
 170 where WINDOW is the affected window, OLDPOS is the last known position of
 171 the cursor and DIR can be `entered' or `left' depending on whether the cursor
 172 is entering the area covered by the text-property property or leaving it."
 173   nil nil nil
 174   (if cursor-sensor-mode
 175       (add-hook 'pre-redisplay-functions #'cursor-sensor--detect
 176                 nil t)
 177     (remove-hook  'pre-redisplay-functions #'cursor-sensor--detect
 178                 t)))
 179
 180 (provide 'cursor-sensor)
 181 ;;; cursor-sensor.el ends here