cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/ilisp-cmp.el

   1 ;;; -*- Mode: Emacs-Lisp -*-
   2
   3 ;;; ilisp-cmp.el --
   4 ;;; ILISP completion
   5 ;;; The basic idea behind the completion stuff is to use as much of
   6 ;;; the standard Emacs stuff as possible.  The extensions here go out
   7 ;;; to the inferior LISP to complete symbols if necessary.
   8 ;;;
   9 ;;; This file is part of ILISP.
  10 ;;; Please refer to the file COPYING for copyrights and licensing
  11 ;;; information.
  12 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  13 ;;; of present and past contributors.
  14 ;;;
  15 ;;; $Id: ilisp-cmp.el,v 1.4 2002-06-03 23:36:59 wbd Exp $
  16
  17 (defun ilisp-display-choices (symbol choices)
  18   "Display the possible choices for SYMBOL in alist CHOICES."
  19   (with-output-to-temp-buffer "*Completions*"
  20     (display-completion-list
  21      (sort
  22       (all-completions (lisp-symbol-name symbol) choices)
  23       'string-lessp))))
  24
  25 ;;;%%ilisp-can-complete
  26 (defun ilisp-can-complete (symbol function-p)
  27   "Return T if ilisp completion can complete SYMBOL from the current table."
  28   (and ilisp-original
  29        (string= (lisp-symbol-package ilisp-original)
  30                 (lisp-symbol-package symbol))
  31        (string= (lisp-symbol-delimiter ilisp-original)
  32                 (lisp-symbol-delimiter symbol))
  33        (lisp-prefix-p (lisp-symbol-name ilisp-original)
  34                       (lisp-symbol-name symbol))
  35        (eq function-p ilisp-original-function-p)))
  36
  37 ;;;%%ilisp-complete
  38 (defun ilisp-complete (symbol &optional function-p)
  39   "Return the possible completions for symbol from the inferior LISP.
  40 The type of the result is a list.  If FUNCTION-P is T, only symbols
  41 with function bindings will be considered.  If no package is specified
  42 the buffer package will be used."
  43   (let* ((choices-string
  44           (ilisp-send
  45            (format  (ilisp-value 'ilisp-complete-command)
  46                     (lisp-symbol-name symbol) (lisp-symbol-package symbol)
  47                     function-p
  48                     (string= (lisp-symbol-delimiter symbol) ":")
  49                     ilisp-*prefix-match*)
  50            (if (not ilisp-complete)
  51                (concat "Complete "
  52                        (if function-p "function ")
  53                        (lisp-buffer-symbol symbol)))
  54            'complete))
  55          choices)
  56     (if (or (ilisp-value 'comint-errorp t)
  57             (ignore-errors (string-match ilisp-error-regexp choices-string)))
  58         (setq choices 'error)
  59       (setq choices (read choices-string)
  60             choices (if (eq choices 'NIL) nil choices)))
  61     (unless (listp choices)
  62       (lisp-display-output choices-string)
  63       (error "Error completing %s" (lisp-buffer-symbol symbol)))
  64     (setq ilisp-original symbol
  65           ilisp-original-function-p function-p
  66           ilisp-original-table choices)))
  67
  68 ;;;%%ilisp-completion-table
  69 (defun ilisp-completion-table (symbol function-p)
  70   "Return the completion table for SYMBOL trying to use the current one.
  71 If FUNCTION-P is T, only symbols with function cells will be returned."
  72   (if (ilisp-can-complete symbol function-p)
  73       ilisp-original-table
  74       (ilisp-complete symbol function-p)))
  75
  76 ;;;%%Minibuffer completion
  77 (defun ilisp-restore-prefix ()
  78   "Restore the prefix from ilisp-mini-prefix at the start of the minibuffer."
  79   (if ilisp-mini-prefix
  80       (save-excursion
  81         (goto-char (ilisp-minibuffer-prompt-end))
  82         (insert ilisp-mini-prefix)
  83         (setq ilisp-mini-prefix nil))))
  84
  85 ;;; Support for Emacs 21 minibuffer prompt
  86 (defun ilisp-minibuffer-prompt-end ()
  87   (if (fboundp 'minibuffer-prompt-end)
  88       (minibuffer-prompt-end)
  89     (point-min)))
  90
  91 ;;;
  92 (defun ilisp-current-choice ()
  93   "Set up the minibuffer completion table for the current symbol.
  94 If there is a paren at the start of the minibuffer, or there is not an
  95 ilisp-table, this will be from the inferior LISP.  Otherwise, it will
  96 be the ilisp-table."
  97   (if (or (null ilisp-table) (eq (char-after (ilisp-minibuffer-prompt-end)) ?\())
  98       (progn
  99         (let* ((symbol-info (lisp-previous-symbol))
 100                (symbol (car symbol-info)))
 101           (setq minibuffer-completion-table
 102                 (ilisp-completion-table symbol ilisp-completion-function-p)))
 103         (save-excursion
 104           (skip-chars-backward "^: \(")
 105           (setq ilisp-mini-prefix (buffer-substring (ilisp-minibuffer-prompt-end) (point)))
 106           (delete-region (ilisp-minibuffer-prompt-end) (point)))
 107         ;; Nothing can match this table
 108         (if (not minibuffer-completion-table)
 109             (setq minibuffer-completion-table '((" ")))))
 110       (setq minibuffer-completion-table ilisp-table
 111             minibuffer-completion-predicate nil)))
 112
 113 ;;;%%Commands
 114 (defvar ilisp-completion-help
 115   (lookup-key minibuffer-local-must-match-map "?"))
 116 (defun ilisp-completion-help ()
 117   "Inferior LISP minibuffer completion help."
 118   (interactive)
 119   (ilisp-current-choice)
 120   (funcall ilisp-completion-help)
 121   (ilisp-restore-prefix))
 122
 123 ;;;
 124 (defvar ilisp-completion
 125   (lookup-key minibuffer-local-must-match-map "\t"))
 126 (defun ilisp-completion ()
 127   "Inferior LISP minibuffer complete."
 128   (interactive)
 129   (ilisp-current-choice)
 130   (funcall ilisp-completion)
 131   (ilisp-restore-prefix))
 132
 133 ;;;
 134 (defvar ilisp-completion-word
 135   (lookup-key minibuffer-local-must-match-map " "))
 136 (defun ilisp-completion-word ()
 137   "Inferior LISP minibuffer complete word."
 138   (interactive)
 139   (if (eq (char-after (ilisp-minibuffer-prompt-end)) ?\()
 140       (insert " ")
 141       (ilisp-current-choice)
 142       (funcall ilisp-completion-word)
 143       (ilisp-restore-prefix)))
 144
 145 ;;;
 146 (defun ilisp-completion-paren ()
 147   "Only allow a paren if ilisp-paren is T."
 148   (interactive)
 149   (if ilisp-paren
 150       (if (or (eq last-input-char ?\() (eq (char-after (ilisp-minibuffer-prompt-end)) ?\())
 151           (insert last-input-char)
 152           (beep))
 153       (beep)))
 154
 155 ;;;
 156 (defvar ilisp-completion-exit
 157   (lookup-key minibuffer-local-must-match-map "\n"))
 158 (defun ilisp-completion-exit ()
 159   "Inferior LISP completion complete and exit."
 160   (interactive)
 161   (if (eq (char-after (ilisp-minibuffer-prompt-end)) ?\()
 162       (progn (find-unbalanced-lisp nil)
 163              (exit-minibuffer))
 164       (if ilisp-no-complete
 165           (exit-minibuffer)
 166           (if (= (ilisp-minibuffer-prompt-end) (point-max))
 167               (exit-minibuffer)
 168               (ilisp-current-choice)
 169               (unwind-protect (funcall ilisp-completion-exit)
 170                 (ilisp-restore-prefix))))))
 171
 172 ;;;%%ilisp-completer
 173 (defun ilisp-completer (symbol function-p)
 174   "Complete SYMBOL from the inferior LISP.
 175 If FUNCTION-P is T, only function symbols are returned.
 176 Return (SYMBOL LCS-SYMBOL CHOICES UNIQUEP)."
 177   (let* ((name (lisp-symbol-name symbol))
 178          (table (ilisp-completion-table symbol function-p))
 179          (choice (and table (try-completion name table))))
 180     (cond ((eq choice t)                ; Name is it
 181            (list symbol symbol nil t))
 182           ((string= name choice)        ; Name is LCS
 183            (list symbol symbol (all-completions name table) nil))
 184           (choice                       ; New LCS
 185            (let ((symbol
 186                   (lisp-symbol (lisp-symbol-package symbol)
 187                                (lisp-symbol-delimiter symbol)
 188                                choice)))
 189              (list symbol symbol (all-completions choice table) nil)))
 190           ((and (not ilisp-*prefix-match*) table)       ;Try partial matches
 191            (let ((matches
 192                   (completer name table nil (regexp-quote completer-words))))
 193              (cons (lisp-symbol (lisp-symbol-package symbol)
 194                                 (lisp-symbol-delimiter symbol)
 195                                 (car matches))
 196                    (cons  (lisp-symbol (lisp-symbol-package symbol)
 197                                        (lisp-symbol-delimiter symbol)
 198                                        (car (cdr matches)))
 199                           (cdr (cdr matches)))))))))
 200
 201
 202 ;;;%%ilisp-read
 203 (defun ilisp-completion-map ()
 204   "Set up the ilisp-completion-map from lisp-mode-map for the ilisp
 205 readers and return it."
 206   (if (not ilisp-completion-map)
 207       (progn
 208         (if (fboundp 'set-keymap-parent)
 209             (progn
 210               (setq ilisp-completion-map (make-sparse-keymap))
 211               (set-keymap-parent ilisp-completion-map lisp-mode-map))
 212           (setq ilisp-completion-map (copy-keymap lisp-mode-map)))
 213         (define-key ilisp-completion-map " "  'ilisp-completion-word)
 214         (define-key ilisp-completion-map "\t" 'ilisp-completion)
 215         (define-key ilisp-completion-map "?" 'ilisp-completion-help)
 216         (define-key ilisp-completion-map "\M-\t" 'ilisp-completion)
 217         (define-key ilisp-completion-map "\n" 'ilisp-completion-exit)
 218         (define-key ilisp-completion-map "\r" 'ilisp-completion-exit)
 219         (define-key ilisp-completion-map "\C-g" 'abort-recursive-edit)
 220         (define-key ilisp-completion-map "(" 'ilisp-completion-paren)
 221         (define-key ilisp-completion-map ")" 'ilisp-completion-paren)
 222         (define-key ilisp-completion-map "'" nil)
 223         (define-key ilisp-completion-map "#" nil)
 224         (define-key ilisp-completion-map "\"" nil)))
 225   ilisp-completion-map)
 226
 227 ;;;
 228 (defun ilisp-read (prompt &optional initial-contents)
 229   "PROMPT in the minibuffer and return the result.
 230 The optional INITIAL-CONTENTS may be specified as an initial value
 231 Completion of symbols though the inferior LISP is allowed."
 232   (let ((ilisp-complete t)
 233         (ilisp-paren t)
 234         (ilisp-no-complete t)
 235         (ilisp-completion-package (lisp-buffer-package)))
 236     (read-from-minibuffer prompt initial-contents
 237                           (ilisp-completion-map))))
 238
 239 ;;;%%lisp-read-program
 240 (defvar lisp-program-map nil
 241   "Minibuffer map for reading a program and arguments.")
 242
 243
 244 ;;;
 245 (defun lisp-read-program (prompt &optional initial)
 246   "Read a program with PROMPT and INITIAL.
 247 TAB or Esc-TAB will complete filenames."
 248   (unless lisp-program-map
 249     (if (fboundp 'set-keymap-parent)
 250         (progn
 251           (setq lisp-program-map (make-sparse-keymap))
 252           (set-keymap-parent lisp-program-map minibuffer-local-map))
 253       (setq lisp-program-map (copy-keymap minibuffer-local-map)))
 254     (define-key lisp-program-map "\M-\t" 'comint-dynamic-complete)
 255     (define-key lisp-program-map "\t" 'comint-dynamic-complete)
 256     (define-key lisp-program-map "?" 'comint-dynamic-list-completions))
 257   (read-from-minibuffer prompt initial lisp-program-map))
 258
 259
 260 ;;;%%ilisp-read-symbol
 261 (defun ilisp-read-symbol (prompt &optional default function-p no-complete)
 262   "PROMPT in the minibuffer and return a symbol from the inferior LISP.
 263 PROMPT may use an optional DEFAULT. If FUNCTION-P is T, only symbols with
 264 function values will be returned.  If NO-COMPLETE is T, then
 265 uncompleted symbols will be allowed."
 266   (let* ((ilisp-complete t)
 267          (ilisp-no-complete no-complete)
 268          (ilisp-completion-package (lisp-buffer-package))
 269          (ilisp-completion-function-p function-p)
 270          (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
 271     (if (equal string "")
 272         default
 273         (lisp-string-to-symbol string))))
 274
 275 ;;;%%ilisp-completing-read
 276 (defun ilisp-completing-read (prompt table &optional default)
 277   "Read with PROMPT from an alist of TABLE.  No input returns DEFAULT.
 278 Symbols are from table, other specs are in parentheses."
 279   (let* ((ilisp-complete t)
 280          (ilisp-table table)
 281          (ilisp-completion-package (lisp-buffer-package))
 282          (ilisp-paren
 283           (let ((entry table) (done nil))
 284             (while (and entry (not done))
 285               (setq done (= (elt (car (car entry)) 0) ?\()
 286                     entry (cdr entry)))
 287             done))
 288          (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
 289     (if (string= string "") default string)))
 290
 291
 292
 293 ;;;%%complete-lisp
 294 (autoload 'complete "completion" "Complete previous symbol." t)
 295 (defun complete-lisp (mode)
 296   "Complete the current symbol using information from the current ILISP buffer.
 297 If in a string, complete as a filename.  If called with
 298 a positive prefix force all symbols to be considered.  If called with
 299 a negative prefix, undo the last completion.  Partial completion is
 300 allowed unless ilisp-*prefix-match* is T.  If a symbol starts after a
 301 left paren or #', then only function symbols will be considered.
 302 Package specifications are also allowed and the distinction between
 303 internal and exported symbols is considered."
 304   (interactive "P")
 305   (if (< (prefix-numeric-value mode) 0)
 306       (completer-undo)
 307       (let* ((filep (save-excursion
 308                       (skip-chars-backward "^ \t\n")
 309                       (= (or (char-after (point)) ?\") ?\")))
 310              )
 311         (if filep
 312             (comint-dynamic-complete)
 313             ;; (ilisp-pathname-complete)
 314             (let* ((symbol-info (lisp-previous-symbol))
 315                    (symbol (car symbol-info))
 316                    (name (lisp-symbol-name symbol))
 317                    (choice (ilisp-completer
 318                             symbol
 319                             (if (not mode) (car (cdr symbol-info)))))
 320                    (match (lisp-buffer-symbol (car choice)))
 321                    (lcs (lisp-buffer-symbol (car (cdr choice))))
 322                    (choices (car (cdr (cdr choice))))
 323                    (unique (car (cdr (cdr (cdr choice))))))
 324               (skip-chars-backward " \t\n")
 325               (completer-goto match lcs choices unique
 326                               (ilisp-value 'ilisp-symbol-delimiters)
 327                               completer-words)))
 328         (message "Completed"))))
 329
 330
 331 ;;; ilisp-pathname-complete --
 332 ;;; Incomplete :) function.  You are most welcome to provide an
 333 ;;; implementation complying with the IIR #1 appeared on ILISP@CONS.ORG.
 334 ;;; 19990709 Marco Antoniotti
 335
 336 (defun ilisp-pathname-complete ()
 337   "Completes the filename, trying to translate LOGICAL-PATHNAMES as well."
 338   (let ((maybe-logical-pathname-p (save-excursion
 339                                     (skip-chars-backward "^ :\t\n")
 340                                     (= (char-after (point)) ?\:)))
 341         )
 342     (if (not maybe-logical-pathname-p)
 343         (comint-dynamic-complete)
 344         ())))
 345
 346 ;;; end of file -- ilisp-cmp.el --