lisp/emacs-lisp/cursor-sensor.el

   1 ;;; cursor-sensor.el --- React to cursor movement  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015  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 (defvar cursor-sensor-inhibit nil)
  35
  36 (defun cursor-sensor--intangible-p (pos)
  37   (let ((p (get-pos-property pos 'cursor-intangible)))
  38     (if p
  39         (let (a b)
  40           (if (and (setq a (get-char-property pos 'cursor-intangible))
  41                    (setq b (if (> pos (point-min))
  42                                (get-char-property (1- pos) 'cursor-intangible)))
  43                    (not (eq a b)))
  44               ;; If we're right between two different intangible thingies,
  45               ;; we can stop here.  This is not quite consistent with the
  46               ;; interpretation of "if it's sticky, then this boundary is
  47               ;; itself intangible", but it's convenient (and it better matches
  48               ;; the behavior of `intangible', making it easier to port code).
  49               nil p))
  50       p)))
  51
  52 (defun cursor-sensor-tangible-pos (curpos window &optional second-chance)
  53   (let ((newpos curpos))
  54     (when (cursor-sensor--intangible-p newpos)
  55       (let ((oldpos (window-parameter window 'cursor-intangible--last-point)))
  56         (cond
  57          ((or (and (integerp oldpos) (< oldpos newpos))
  58               (eq newpos (point-min)))
  59           (while
  60               (when (< newpos (point-max))
  61                 (setq newpos
  62                       (if (get-char-property newpos 'cursor-intangible)
  63                           (next-single-char-property-change
  64                            newpos 'cursor-intangible nil (point-max))
  65                         (1+ newpos)))
  66                 (cursor-sensor--intangible-p newpos))))
  67          (t ;; (>= oldpos newpos)
  68           (while
  69               (when (> newpos (point-min))
  70                 (setq newpos
  71                       (if (get-char-property (1- newpos) 'cursor-intangible)
  72                           (previous-single-char-property-change
  73                            newpos 'cursor-intangible nil (point-min))
  74                         (1- newpos)))
  75                 (cursor-sensor--intangible-p newpos)))))
  76         (if (not (and (or (eq newpos (point-min)) (eq newpos (point-max)))
  77                       (cursor-sensor--intangible-p newpos)))
  78             ;; All clear, we're good to go.
  79             newpos
  80           ;; We're still on an intangible position because we bumped
  81           ;; into an intangible BOB/EOB: try to move in the other direction.
  82           (if second-chance
  83               ;; Actually, we tried already and that failed!
  84               curpos
  85             (cursor-sensor-tangible-pos newpos window 'second-chance)))))))
  86
  87 (defun cursor-sensor-move-to-tangible (window)
  88   (let* ((curpos (window-point window))
  89          (newpos (cursor-sensor-tangible-pos curpos window)))
  90     (when newpos (set-window-point window newpos))
  91     (set-window-parameter window 'cursor-intangible--last-point
  92                           (or newpos curpos))))
  93
  94 (defun cursor-sensor--move-to-tangible (window)
  95   (unless cursor-sensor-inhibit
  96     (cursor-sensor-move-to-tangible window)))
  97
  98 ;;;###autoload
  99 (define-minor-mode cursor-intangible-mode
 100   "Keep cursor outside of any `cursor-intangible' text property."
 101   nil nil nil
 102   (if cursor-intangible-mode
 103       (add-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible
 104                 nil t)
 105     (remove-hook 'pre-redisplay-functions #'cursor-sensor--move-to-tangible t)))
 106
 107 ;;; Detect cursor movement.
 108
 109 (defun cursor-sensor--detect (window)
 110   (unless cursor-sensor-inhibit
 111     (let* ((point (window-point window))
 112            ;; It's often desirable to make the cursor-sensor-functions property
 113            ;; non-sticky on both ends, but that means get-pos-property might
 114            ;; never see it.
 115            (new (or (get-char-property point 'cursor-sensor-functions)
 116                     (unless (bobp)
 117                       (get-char-property (1- point) 'cursor-sensor-functions))))
 118            (old (window-parameter window 'cursor-sensor--last-state))
 119            (oldposmark (car old))
 120            (oldpos (or (if oldposmark (marker-position oldposmark))
 121                        (point-min)))
 122            (start (min oldpos point))
 123            (end (max oldpos point)))
 124       (unless (or (null old) (eq (marker-buffer oldposmark) (current-buffer)))
 125         ;; `window' does not display the same buffer any more!
 126         (setcdr old nil))
 127       (if (or (and (null new) (null (cdr old)))
 128               (and (eq new (cdr old))
 129                    (eq (next-single-property-change
 130                         start 'cursor-sensor-functions nil end)
 131                        end)))
 132           ;; Clearly nothing to do.
 133           nil
 134         ;; Maybe something to do.  Let's see exactly what needs to run.
 135         (let* ((missing-p
 136                 (lambda (f)
 137                   "Non-nil if F is missing somewhere between START and END."
 138                   (let ((pos start)
 139                         (missing nil))
 140                     (while (< pos end)
 141                       (setq pos (next-single-property-change
 142                                  pos 'cursor-sensor-functions
 143                                  nil end))
 144                       (unless (memq f (get-char-property
 145                                        pos 'cursor-sensor-functions))
 146                         (setq missing t)))
 147                     missing))))
 148           (dolist (f (cdr old))
 149             (unless (and (memq f new) (not (funcall missing-p f)))
 150               (funcall f window oldpos 'left)))
 151           (dolist (f new)
 152             (unless (and (memq f (cdr old)) (not (funcall missing-p f)))
 153               (funcall f window oldpos 'entered)))))
 154
 155       ;; Remember current state for next time.
 156       ;; Re-read cursor-sensor-functions since the functions may have moved
 157       ;; window-point!
 158       (if old
 159           (progn (move-marker (car old) point)
 160                  (setcdr old new))
 161         (set-window-parameter window 'cursor-sensor--last-state
 162                               (cons (copy-marker point) new))))))
 163
 164 ;;;###autoload
 165 (define-minor-mode cursor-sensor-mode
 166   "Handle the `cursor-sensor-functions' text property.
 167 This property should hold a list of functions which react to the motion
 168 of the cursor.  They're called with three arguments (WINDOW OLDPOS DIR)
 169 where WINDOW is the affected window, OLDPOS is the last known position of
 170 the cursor and DIR can be `left' or `entered' depending on whether the cursor is
 171 entering the area covered by the text-property property or leaving it."
 172   nil nil nil
 173   (if cursor-sensor-mode
 174       (add-hook 'pre-redisplay-functions #'cursor-sensor--detect
 175                 nil t)
 176     (remove-hook  'pre-redisplay-functions #'cursor-sensor--detect
 177                 t)))
 178
 179 (provide 'cursor-sensor)
 180 ;;; cursor-sensor.el ends here