cgit.sxemacs.org Git - sxemacs/blob - lisp/mode-motion.el

   1 ;;; mode-motion.el --- Mode-specific mouse-highlighting of text.
   2
   3 ;; Copyright (C) 1992, 1993, 1997 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: SXEmacs Development Team
   6 ;; Keywords: internal, mouse, dumped
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs 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 ;; SXEmacs 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Not in FSF.
  24
  25 ;;; Commentary:
  26
  27 ;; This file is dumped with SXEmacs (when window system support is compiled in).
  28
  29 ;;; Code:
  30
  31 (defvar mode-motion-hook nil
  32   "Function or functions which are called whenever the mouse moves.
  33 Each function must take a single argument of the motion event.
  34 You should normally use this rather than `mouse-motion-handler', which
  35 does some additional window-system-dependent things.  This hook is local
  36 to every buffer, and should normally be set up by major-modes which want
  37 to use special highlighting.  Every time the mouse moves over a window,
  38 the mode-motion-hook of the buffer of that window is run.")
  39
  40 (make-variable-buffer-local 'mode-motion-hook)
  41
  42 (defvar mode-motion-extent nil)
  43 (make-variable-buffer-local 'mode-motion-extent)
  44
  45 (defvar mode-motion-help-echo-string nil
  46   "String to be added as the 'help-echo property of the mode-motion extent.
  47 In order for this to work, you need to add the hook function
  48 `mode-motion-add-help-echo' to the mode-motion hook.  If this is a function,
  49 it will be called with one argument (the event) and should return a string
  50 to be added.  This variable is local to every buffer.")
  51 (make-variable-buffer-local 'mode-motion-help-echo-string)
  52
  53 (defun mode-motion-ensure-extent-ok (event)
  54   (let ((buffer (event-buffer event)))
  55     (if (and (extent-live-p mode-motion-extent)
  56              (eq buffer (extent-object mode-motion-extent)))
  57         nil
  58       (setq mode-motion-extent (make-extent nil nil buffer))
  59       (set-extent-property mode-motion-extent 'mouse-face 'highlight))))
  60
  61 (defun mode-motion-highlight-internal (event backward forward)
  62   (let* ((buffer (event-buffer event))
  63          (point (and buffer (event-point event))))
  64     (if (and buffer
  65              (not (eq buffer mouse-grabbed-buffer)))
  66         ;; #### ack!! Too many calls to save-window-excursion /
  67         ;; save-excursion (x-track-pointer calls, so does
  68         ;; minibuf-mouse-tracker ...) This needs to be looked
  69         ;; into.  It's complicated by the fact that sometimes
  70         ;; a mode-motion-hook might really want to change
  71         ;; the point.
  72         ;;
  73         ;; #### The save-excursion must come before the
  74         ;; save-window-excursion in order to function properly.  I
  75         ;; haven't given this much thought.  Is it a bug that this
  76         ;; ordering is necessary or is it correct behavior?
  77         (save-excursion
  78           (save-window-excursion
  79             (set-buffer buffer)
  80             (mode-motion-ensure-extent-ok event)
  81             (if point
  82                 ;; Use save-excursion here to avoid
  83                 ;; save-window-excursion seeing a change in
  84                 ;; window point's value which would make the
  85                 ;; display code do a whole lot of useless work
  86                 ;; and making the display flicker horribly.
  87                 (save-excursion
  88                   (goto-char point)
  89                   (condition-case nil (funcall backward) (error nil))
  90                   (setq point (point))
  91                   (condition-case nil (funcall forward) (error nil))
  92                   (if (eq point (point))
  93                       (detach-extent mode-motion-extent)
  94                     (set-extent-endpoints mode-motion-extent point (point))))
  95               ;; not over text; zero the extent.
  96               (detach-extent mode-motion-extent)))))))
  97
  98 (defun mode-motion-highlight-line (event)
  99   "For use as the value of `mode-motion-hook' -- highlight line under mouse."
 100   (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line))
 101
 102 (defun mode-motion-highlight-word (event)
 103   "For use as the value of `mode-motion-hook' -- highlight word under mouse."
 104   (mode-motion-highlight-internal
 105    event
 106    #'(lambda () (default-mouse-track-beginning-of-word nil))
 107    #'(lambda () (default-mouse-track-end-of-word nil))))
 108
 109 (defun mode-motion-highlight-symbol (event)
 110   "For use as the value of `mode-motion-hook' -- highlight symbol under mouse."
 111   (mode-motion-highlight-internal
 112    event
 113    #'(lambda () (default-mouse-track-beginning-of-word t))
 114    #'(lambda () (default-mouse-track-end-of-word t))))
 115
 116 (defun mode-motion-highlight-sexp (event)
 117   "For use as the value of `mode-motion-hook' -- highlight form under mouse."
 118   (mode-motion-highlight-internal
 119    event
 120    #'(lambda ()
 121        (if (= (char-syntax (following-char)) ?\()
 122            nil
 123          (goto-char (scan-sexps (point) -1))))
 124    #'(lambda ()
 125        (if (= (char-syntax (following-char)) ?\))
 126            (forward-char 1))
 127        (goto-char (scan-sexps (point) 1)))))
 128
 129 (defun mode-motion-add-help-echo (event)
 130   "For use as the value of `mode-motion-hook' -- add a 'help-echo property.
 131 This causes the string in the 'help-echo property to be displayed when the
 132 mouse moves over the extent.  See `mode-motion-help-echo-string' for
 133 documentation on how to control the string that is added."
 134   (mode-motion-ensure-extent-ok event)
 135   (let ((string (cond ((null mode-motion-help-echo-string) nil)
 136                       ((stringp mode-motion-help-echo-string)
 137                        mode-motion-help-echo-string)
 138                       (t (funcall mode-motion-help-echo-string event)))))
 139     (if (stringp string)
 140         (set-extent-property mode-motion-extent 'help-echo string))))
 141
 142 \f
 143 (provide 'mode-motion)
 144
 145 ;;; mode-motion.el ends here