home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / mode-motion.el < prev    next >
Encoding:
Text File  |  1992-11-12  |  8.0 KB  |  207 lines
  1. ;; Mode-specific mouse-highlighting of text.
  2. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar mode-motion-hook nil
  21.   "Function or functions which are called whenever the mouse moves.
  22. You should normally use this rather than `mouse-motion-handler', which 
  23. does some additional window-system-dependent things.  This hook is local
  24. to every buffer, and should normally be set up by major-modes which want
  25. to use special highlighting.  Every time the mouse moves over a window,
  26. the mode-motion-hook of the buffer of that window is run.")
  27.  
  28. (make-variable-buffer-local 'mode-motion-hook)
  29.  
  30.  
  31. (defvar mode-motion-extent nil)
  32. (make-variable-buffer-local 'mode-motion-extent)
  33.  
  34.  
  35. (defun mode-motion-highlight-internal (event backward forward)
  36.   (let* ((window (event-window event))
  37.      (screen (if window (window-screen window) (selected-screen)))
  38.      (buffer (and window (window-buffer window)))
  39.      (point (and buffer (event-point event))))
  40.     (if buffer
  41.     (save-excursion
  42.       (set-buffer buffer)
  43.       (if point
  44.           (progn
  45.         (goto-char point)
  46.         (condition-case nil (funcall backward) (error nil))
  47.         (setq point (point))
  48.         (condition-case nil (funcall forward) (error nil))
  49.         (if (and mode-motion-extent (extent-buffer mode-motion-extent))
  50.             (set-extent-endpoints mode-motion-extent point (point))
  51.           (setq mode-motion-extent (make-extent point (point)))
  52.           (set-extent-attribute mode-motion-extent 'highlight)))
  53.         ;; not over text; zero the extent.
  54.         (if (and mode-motion-extent (extent-buffer mode-motion-extent)
  55.              (not (eq (extent-start-position mode-motion-extent)
  56.                   (extent-end-position mode-motion-extent))))
  57.         (set-extent-endpoints mode-motion-extent 1 1)))))))
  58.  
  59.  
  60. (defun mode-motion-highlight-line (event)
  61.   "For use as the value of `mode-motion-hook' -- highlight line under mouse."
  62.   (mode-motion-highlight-internal event 'beginning-of-line 'end-of-line))
  63.  
  64. (defun mode-motion-highlight-word (event)
  65.   "For use as the value of `mode-motion-hook' -- highlight word under mouse."
  66.   (mode-motion-highlight-internal
  67.    event
  68.    (function (lambda () (mouse-track-beginning-of-word nil)))
  69.    (function (lambda () (mouse-track-end-of-word nil)))))
  70.  
  71. (defun mode-motion-highlight-symbol (event)
  72.   "For use as the value of `mode-motion-hook' -- highlight symbol under mouse."
  73.   (mode-motion-highlight-internal
  74.    event
  75.    (function (lambda () (mouse-track-beginning-of-word t)))
  76.    (function (lambda () (mouse-track-end-of-word t)))))
  77.  
  78. (defun mode-motion-highlight-sexp (event)
  79.   "For use as the value of `mode-motion-hook' -- highlight form under mouse."
  80.   (mode-motion-highlight-internal
  81.    event
  82.    (function (lambda ()
  83.            (if (= (char-syntax (following-char)) ?\()
  84.            nil
  85.          (goto-char (scan-sexps (point) -1)))))
  86.    (function (lambda ()
  87.            (if (= (char-syntax (following-char)) ?\))
  88.            (forward-char 1))
  89.            (goto-char (scan-sexps (point) 1))))))
  90.  
  91.  
  92. ;;; Minibuffer hackery
  93.  
  94. (defun minibuf-mouse-tracker (event)
  95.   ;; Used as the mode-motion-hook of the minibuffer window, which is the
  96.   ;; value of `mouse-grabbed-buffer' while the minibuffer is active.  If
  97.   ;; the word under the mouse is a valid minibuffer completion, then it
  98.   ;; is highlighted.
  99.   ;;
  100.   ;; We do some special voodoo when we're reading a pathname, because
  101.   ;; the way filename completion works is funny.  Possibly there's some
  102.   ;; more general way this could be dealt with...
  103.   ;;
  104.   (let ((filename-kludge-p (eq minibuffer-completion-table
  105.                    'read-file-name-internal)))
  106.     (mode-motion-highlight-internal
  107.      event
  108.      (function
  109.       (lambda () (mouse-track-beginning-of-word
  110.           (if filename-kludge-p 'nonwhite t))))
  111.      (function
  112.       (lambda ()
  113.     (let ((p (point)) string)
  114.       (mouse-track-end-of-word (if filename-kludge-p 'nonwhite t))
  115.       (if (or (= p (point)) (null minibuffer-completion-table))
  116.           (goto-char p)
  117.         (setq string (buffer-substring p (point)))
  118.         (if filename-kludge-p
  119.         (setq string (minibuf-select-kludge-filename string)))
  120.         ;; try-completion bogusly returns a string even when that string
  121.         ;; is complete if that string is also a prefix for other
  122.         ;; completions.  This means that we can't just do the obvious
  123.         ;; thing, (eq t (try-completion ...)).
  124.         (let ((comp (try-completion string minibuffer-completion-table
  125.                     minibuffer-completion-predicate)))
  126.           (or (eq comp t)
  127.           (and (equal comp string)
  128.                (or (null minibuffer-completion-predicate)
  129.                (stringp minibuffer-completion-predicate) ; ???
  130.                (funcall minibuffer-completion-predicate
  131.                     (if (vectorp minibuffer-completion-table)
  132.                     (intern-soft string
  133.                      minibuffer-completion-table)
  134.                       string))))
  135.           (goto-char p))))))))))
  136.  
  137.  
  138. (defun minibuf-select-kludge-filename (string)
  139.   (save-excursion
  140.     (set-buffer mouse-grabbed-buffer) ; the minibuf
  141.     (expand-file-name (concat (file-name-directory (buffer-string)) string))))
  142.  
  143.  
  144. (defun minibuf-select-highlighted-completion (event)
  145.   "Select the highlighted text under the mouse as a minibuffer response.
  146. When the minibuffer is being used to prompt the user for a completion,
  147. any valid completions which are visible on the screen will highlight
  148. when the mouse moves over them.  Clicking \\<minibuffer-local-map>\
  149. \\[minibuf-select-highlighted-completion] will select the
  150. highlighted completion under the mouse.
  151.  
  152. If the mouse is clicked while while not over a highlighted completion,
  153. then the global binding of \\[minibuf-select-highlighted-completion] \
  154. will be executed instead.  In this\nway you can get at the normal global \
  155. behavior of \\[minibuf-select-highlighted-completion] as well as
  156. the special minibuffer behavior."
  157.   (interactive "e")
  158.   (let ((filename-kludge-p (eq minibuffer-completion-table
  159.                    'read-file-name-internal))
  160.     completion
  161.     command-p)
  162.     (save-excursion
  163.       (minibuf-mouse-tracker event) ; make sure we're sync'd
  164.       (set-buffer (window-buffer (event-window event)))
  165.       (if (or (null mode-motion-extent)
  166.           (= (extent-start-position mode-motion-extent)
  167.          (extent-end-position mode-motion-extent)))
  168.       (setq command-p t)
  169.     ;; ...else user has selected a highlighted completion.
  170.     (setq completion
  171.           (buffer-substring (extent-start-position mode-motion-extent)
  172.                 (extent-end-position mode-motion-extent)))
  173.     (if filename-kludge-p
  174.         (setq completion (minibuf-select-kludge-filename completion)))
  175.     ;; narrow the extent so that it's not hanging around in *Completions*
  176.     (set-extent-endpoints mode-motion-extent 1 1)
  177.     (set-buffer mouse-grabbed-buffer)
  178.     (erase-buffer)
  179.     (insert completion)))
  180.     ;; we need to execute the command or do the throw outside of the
  181.     ;; save-excursion.
  182.     (if command-p
  183.     (let ((command (lookup-key global-map (vector current-mouse-event))))
  184.       (if command
  185.           (call-interactively command)
  186.         (if minibuffer-completion-table
  187.         (error
  188.           "Highlighted words are valid completions.  You may select one.")
  189.           (error "no completions"))))
  190.       ;; things get confused if the minibuffer is terminated while
  191.       ;; not selected.
  192.       (select-window (minibuffer-window))
  193.       (if (and filename-kludge-p (file-directory-p completion))
  194.       ;; if the user clicked middle on a directory name, display the
  195.       ;; files in that directory.
  196.       (progn
  197.         (goto-char (point-max))
  198.         (minibuffer-completion-help))
  199.     ;; otherwise, terminate input
  200.     (throw 'exit nil)))))
  201.  
  202. (define-key minibuffer-local-map 'button2
  203.   'minibuf-select-highlighted-completion)
  204.  
  205.  
  206. (provide 'mode-motion)
  207.