lisp/progmodes/sym-comp.el

   1 ;;; sym-comp.el --- mode-dependent symbol completion
   2
   3 ;; Copyright (C) 2004  Dave Love
   4
   5 ;; Author: Dave Love <fx@gnu.org>
   6 ;; Keywords: extensions
   7 ;; $Revision: 1.1 $
   8 ;; URL: http://www.loveshack.ukfsn.org/emacs
   9
  10 ;; This file 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 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This file 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; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This defines `symbol-complete', which is a generalization of the
  28 ;; old `lisp-complete-symbol'.  It provides the following hooks to
  29 ;; allow major modes to set up completion appropriate for the mode:
  30 ;; `symbol-completion-symbol-function',
  31 ;; `symbol-completion-completions-function',
  32 ;; `symbol-completion-predicate-function',
  33 ;; `symbol-completion-transform-function'.  Typically it is only
  34 ;; necessary for a mode to set
  35 ;; `symbol-completion-completions-function' locally and to bind
  36 ;; `symbol-complete' appropriately.
  37
  38 ;; It's unfortunate that there doesn't seem to be a good way of
  39 ;; combining this with `complete-symbol'.
  40
  41 ;; There is also `symbol-completion-try-complete', for use with
  42 ;; Hippie-exp.
  43
  44 ;;; Code:
  45
  46 ;;;; Mode-dependent symbol completion.
  47
  48 (defun symbol-completion-symbol ()
  49   "Default `symbol-completion-symbol-function'.
  50 Uses `current-word' with the buffer narrowed to the part before
  51 point."
  52   (save-restriction
  53     ;; Narrow in case point is in the middle of a symbol -- we want
  54     ;; just the preceeding part.
  55     (narrow-to-region (point-min) (point))
  56     (current-word)))
  57
  58 (defvar symbol-completion-symbol-function 'symbol-completion-symbol
  59   "Function to return a partial symbol before point for completion.
  60 The value it returns should be a string (or nil).
  61 Major modes may set this locally if the default isn't appropriate.")
  62
  63 (defvar symbol-completion-completions-function nil
  64   "Function to return possible symbol completions.
  65 It takes an argument which is the string to be completed and
  66 returns a value suitable for the second argument of
  67 `try-completion'.  This value need not use the argument, i.e. it
  68 may be all possible completions, such as `obarray' in the case of
  69 Emacs Lisp.
  70
  71 Major modes may set this locally to allow them to support
  72 `symbol-complete'.  See also `symbol-completion-symbol-function',
  73 `symbol-completion-predicate-function' and
  74 `symbol-completion-transform-function'.")
  75
  76 (defvar symbol-completion-predicate-function nil
  77   "If non-nil, function to return a predicate for selecting symbol completions.
  78 The function gets two args, the positions of the beginning and
  79 end of the symbol to be completed.
  80
  81 Major modes may set this locally if the default isn't
  82 appropriate.  This is a function returning a predicate so that
  83 the predicate can be context-dependent, e.g. to select only
  84 function names if point is at a function call position.  The
  85 function's args may be useful for determining the context.")
  86
  87 (defvar symbol-completion-transform-function nil
  88   "If non-nil, function to transform symbols in the symbol-completion buffer.
  89 E.g., for Lisp, it may annotate the symbol as being a function,
  90 not a variable.
  91
  92 The function takes the symbol name as argument.  If it needs to
  93 annotate this, it should return a value suitable as an element of
  94 the list passed to `display-completion-list'.
  95
  96 The predicate being used for selecting completions (from
  97 `symbol-completion-predicate-function') is available
  98 dynamically-bound as `symbol-completion-predicate' in case the
  99 transform needs it.")
 100
 101 (defvar displayed-completions)
 102
 103 ;;;###autoload
 104 (defun symbol-complete (&optional predicate)
 105   "Perform completion of the symbol preceding point.
 106 This is done in a way appropriate to the current major mode,
 107 perhaps by interrogating an inferior interpreter.  Compare
 108 `complete-symbol'.
 109 If no characters can be completed, display a list of possible completions.
 110 Repeating the command at that point scrolls the list.
 111
 112 When called from a program, optional arg PREDICATE is a predicate
 113 determining which symbols are considered.
 114
 115 This function requires `symbol-completion-completions-function'
 116 to be set buffer-locally.  Variables `symbol-completion-symbol-function',
 117 `symbol-completion-predicate-function' and
 118 `symbol-completion-transform-function' are also consulted."
 119   (interactive)
 120   ;; Fixme: Punt to `complete-symbol' in this case?
 121   (unless (functionp symbol-completion-completions-function)
 122     (error "symbol-completion-completions-function not defined"))
 123   (let ((window (get-buffer-window "*Completions*")))
 124     (let* ((pattern (or (funcall symbol-completion-symbol-function)
 125                         (error "No preceding symbol to complete")))
 126            (predicate (or predicate
 127                           (if symbol-completion-predicate-function
 128                               (funcall symbol-completion-predicate-function
 129                                        (- (point) (length pattern))
 130                                        (point)))))
 131            (completions (funcall symbol-completion-completions-function
 132                                  pattern))
 133            (completion (try-completion pattern completions predicate)))
 134       ;; If this command was repeated, and there's a fresh completion
 135       ;; window with a live buffer and a displayed completion list
 136       ;; matching the current completions, then scroll the window.
 137       (unless (and (eq last-command this-command)
 138                    window (window-live-p window) (window-buffer window)
 139                    (buffer-name (window-buffer window))
 140                    (with-current-buffer (window-buffer window)
 141                      (if (equal displayed-completions
 142                                 (all-completions pattern completions predicate))
 143                          (progn
 144                            (if (pos-visible-in-window-p (point-max) window)
 145                                (set-window-start window (point-min))
 146                              (save-selected-window
 147                                (select-window window)
 148                                (scroll-up)))
 149                            t))))
 150         ;; Otherwise, do completion.
 151         (cond ((eq completion t))
 152               ((null completion)
 153                (message "Can't find completion for \"%s\"" pattern)
 154                (ding))
 155               ((not (string= pattern completion))
 156                (delete-region (- (point) (length pattern)) (point))
 157                (insert completion))
 158               (t
 159                (message "Making completion list...")
 160                (let* ((list (all-completions pattern completions predicate))
 161                       ;; In case the transform needs to access it.
 162                       (symbol-completion-predicate predicate)
 163                       ;; Copy since list is side-effected by sorting.
 164                       (copy (copy-sequence list)))
 165                  (setq list (sort list 'string<))
 166                  (if (functionp symbol-completion-transform-function)
 167                      (setq list
 168                            (mapcar (funcall
 169                                     symbol-completion-transform-function)
 170                                    list)))
 171                  (with-output-to-temp-buffer "*Completions*"
 172                    (condition-case ()
 173                        (display-completion-list list pattern) ; Emacs 22
 174                      (error (display-completion-list list))))
 175                  ;; Record the list for determining whether to scroll
 176                  ;; (above).
 177                  (with-current-buffer "*Completions*"
 178                    (set (make-local-variable 'displayed-completions) copy)))
 179                (message "Making completion list...%s" "done")))))))
 180 \f
 181 (eval-when-compile (require 'hippie-exp))
 182
 183 ;;;###autoload
 184 (defun symbol-completion-try-complete (old)
 185   "Completion function for use with `hippie-expand'.
 186 Uses `symbol-completion-symbol-function' and
 187 `symbol-completion-completions-function'.  It is intended to be
 188 used something like this in a major mode which provides symbol
 189 completion:
 190
 191   (if (featurep 'hippie-exp)
 192       (set (make-local-variable 'hippie-expand-try-functions-list)
 193            (cons 'symbol-completion-try-complete
 194                  hippie-expand-try-functions-list)))"
 195   (when (and symbol-completion-symbol-function
 196              symbol-completion-completions-function)
 197     (unless old
 198       (let ((symbol (funcall symbol-completion-symbol-function)))
 199         (he-init-string (- (point) (length symbol)) (point))
 200         (if (not (he-string-member he-search-string he-tried-table))
 201             (push he-search-string he-tried-table))
 202         (setq he-expand-list
 203               (and symbol
 204                    (funcall symbol-completion-completions-function symbol)))))
 205     (while (and he-expand-list
 206                 (he-string-member (car he-expand-list) he-tried-table))
 207       (pop he-expand-list))
 208     (if he-expand-list
 209         (progn
 210           (he-substitute-string (pop he-expand-list))
 211           t)
 212       (if old (he-reset-string))
 213       nil)))
 214 \f
 215 ;;; Emacs Lisp symbol completion.
 216
 217 (defun lisp-completion-symbol ()
 218   "`symbol-completion-symbol-function' for Lisp."
 219   (let ((end (point))
 220         (beg (with-syntax-table emacs-lisp-mode-syntax-table
 221                (save-excursion
 222                  (backward-sexp 1)
 223                  (while (= (char-syntax (following-char)) ?\')
 224                    (forward-char 1))
 225                  (point)))))
 226     (buffer-substring-no-properties beg end)))
 227
 228 (defun lisp-completion-predicate (beg end)
 229   "`symbol-completion-predicate-function' for Lisp."
 230   (save-excursion
 231     (goto-char beg)
 232     (if (not (eq (char-before) ?\())
 233         (lambda (sym)                   ;why not just nil ?   -sm
 234                                         ;To avoid interned symbols with
 235                                         ;no slots.  -- fx
 236           (or (boundp sym) (fboundp sym)
 237               (symbol-plist sym)))
 238       ;; Looks like a funcall position.  Let's double check.
 239       (if (condition-case nil
 240               (progn (up-list -2) (forward-char 1)
 241                      (eq (char-after) ?\())
 242             (error nil))
 243           ;; If the first element of the parent list is an open
 244           ;; parenthesis we are probably not in a funcall position.
 245           ;; Maybe a `let' varlist or something.
 246           nil
 247         ;; Else, we assume that a function name is expected.
 248         'fboundp))))
 249
 250 (defvar symbol-completion-predicate)
 251
 252 (defun lisp-symbol-completion-transform ()
 253   "`symbol-completion-transform-function' for Lisp."
 254   (lambda (elt)
 255     (if (and (not (eq 'fboundp symbol-completion-predicate))
 256              (fboundp (intern elt)))
 257         (list elt " <f>")
 258       elt)))
 259
 260 (provide 'sym-comp)
 261
 262 ;; arch-tag: 6fcce616-f3c4-4751-94b4-710e83144124
 263 ;;; sym-comp.el ends here