cgit.sxemacs.org Git - packages/blob - xemacs-packages/oo-browser/br-compl.el

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         br-compl.el
   4 ;; SUMMARY:      Most functions for performing completion on OO constructs.
   5 ;; USAGE:        GNU Emacs Lisp Library
   6 ;; KEYWORDS:     matching, oop, tools
   7 ;;
   8 ;; AUTHOR:       Bob Weiner
   9 ;; ORG:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:    27-Mar-90
  12 ;; LAST-MOD:      9-Jun-99 at 18:03:57 by Bob Weiner
  13
  14
  15 ;;; ************************************************************************
  16 ;;; Other required Elisp libraries
  17 ;;; ************************************************************************
  18
  19 ;; Requires a number of functions from "br-lib.el", part of the OO-Browser
  20 ;; package.  See the code for functions called but not defined within this
  21 ;; file.
  22
  23 ;;; ************************************************************************
  24 ;;; Public functions
  25 ;;; ************************************************************************
  26
  27 (defun br-all-classes (&optional htable-type duplicates-flag)
  28   "Return list of class names in Environment or optional HTABLE-TYPE.
  29 HTABLE-TYPE may be \"sys\" or \"lib\" or an actual hash table.
  30 List is not sorted unless optional DUPLICATES-FLAG is non-nil, which means cons
  31 the the sorted list of duplicate classes onto the front of the unique class
  32 names list."
  33   (let ((classes
  34          (apply 'append
  35                 (hash-map
  36                  (function (lambda (val-key-cons)
  37                              ;; Copy so that hash-table values are not
  38                              ;; disturbed.
  39                              (copy-sequence (car val-key-cons))))
  40                  (cond ((and (stringp htable-type)
  41                              (not (string-equal htable-type "")))
  42                         (br-get-htable (concat htable-type "-paths")))
  43                        ((hashp htable-type) htable-type)
  44                        (t (br-get-paths-htable)))))))
  45     (if duplicates-flag
  46         (br-duplicate-and-unique-strings (sort classes 'string-lessp))
  47       classes)))
  48
  49 (defun br-buffer-menu ()
  50   "Display in the viewer window a selection list of buffers for the current browser language."
  51   (interactive)
  52   (or (br-in-view-window-p)
  53       (setq *br-prev-listing-window* (selected-window)))
  54   (let ((owind (selected-window))
  55         (ovbuf (save-window-excursion
  56                  (br-to-view-window)
  57                  (current-buffer))))
  58     (buffer-menu t)
  59     (narrow-to-region (point) (point-max))
  60     (let ((buffer-read-only nil)
  61           (file-name))
  62       (while (setq file-name (br-buffer-menu-file-name))
  63         (if (not (and file-name (string-match br-src-file-regexp file-name)))
  64             (delete-region (point) (progn (forward-line 1) (point)))
  65           (forward-line 1))))
  66     (goto-char (point-min))
  67     (widen)
  68     (if (looking-at "^$") ;; No matching buffers
  69         (progn
  70           (switch-to-buffer ovbuf)
  71           (select-window owind)
  72           (beep)
  73           (message
  74            "(OO-Browser):  No appropriate buffers available for selection."))
  75       (set-window-start nil 1)
  76       (substitute-key-definition 'Buffer-menu-select 'br-buffer-menu-select
  77                                  Buffer-menu-mode-map)
  78       (message "(OO-Browser):  Select a buffer for display."))))
  79
  80 (defun br-buffer-menu-file-name ()
  81   "Return file name associated with the current buffer menu line or nil.
  82 Leaves point at the beginning of the current line."
  83   (if (= (point) (point-max))
  84       nil
  85     (beginning-of-line)
  86     (forward-char Buffer-menu-buffer-column)
  87     (let ((start (point)))
  88       ;; End of buffer name marked by tab or two spaces.
  89       (if (not (re-search-forward "\t\\|  "))
  90           nil
  91         (skip-chars-backward " \t")
  92         (let ((buffer
  93                (get-buffer (br-buffer-substring start (point)))))
  94           (beginning-of-line)
  95           (if buffer (buffer-file-name buffer)))))))
  96
  97 (defun br-buffer-menu-select ()
  98   "Display buffer associated with the line that point is on."
  99   (interactive)
 100   (substitute-key-definition 'br-buffer-menu-select 'Buffer-menu-select
 101                              Buffer-menu-mode-map)
 102   (let ((buff (Buffer-menu-buffer t))
 103         (menu (current-buffer)))
 104     (if buff
 105         (progn (switch-to-buffer buff)
 106                (or (eq menu buff)
 107                    (bury-buffer menu)))
 108       (beep))))
 109
 110 (defun br-complete-entry (&optional prompt)
 111   "Interactively completes class or feature name and returns it or nil.
 112 Optional PROMPT is initial prompt string for user."
 113   (interactive)
 114   (let ((default (and (br-in-browser)
 115                       (not (br-in-view-window-p))
 116                       (br-find-class-name)))
 117         (completion-ignore-case nil)
 118         completions
 119         element-name)
 120     (if (not (br-class-path default)) (setq default nil))
 121     ;; Prompt with possible completions of element-name.
 122     (setq prompt (or prompt "Class/Element name:")
 123           completions (append (br-class-completions)
 124                               (br-element-completions))
 125           element-name
 126           (if completions
 127               (completing-read
 128                (format "%s (default %s) " prompt (or default "<None>"))
 129                completions nil 'must-match)
 130             (read-string
 131              (format "%s (default %s) " prompt (or default "<None>")))))
 132     (if (equal element-name "") (setq element-name default))
 133     element-name))
 134
 135 ;;;###autoload
 136 (defun br-complete-symbol ()
 137   "Complete an OO-Browser type or element or an Emacs Lisp symbol preceding point.
 138 The symbol is compared against current Environment entries (or Emacs symbol
 139 table entries) and any needed characters are inserted."
 140   (interactive)
 141   (cond ((and (fboundp 'br-lang-mode)
 142               (eq major-mode (symbol-function 'br-lang-mode)))
 143          (br-complete-type))
 144         (t
 145          (lisp-complete-symbol))))
 146
 147 (defun br-complete-class-name (&optional must-match prompt)
 148   "Interactively completes class name if possible, and returns class name.
 149 Optional MUST-MATCH means class name must match a completion table entry.
 150 Optional PROMPT is intial prompt string for user."
 151   (interactive)
 152   (let ((default (br-find-class-name))
 153         (completion-ignore-case nil)
 154         completions
 155         class-name)
 156     ;; Prompt with possible completions of class-name.
 157     (setq prompt (or prompt "Class name:")
 158           completions (br-class-completions)
 159           class-name
 160           (if completions
 161               (completing-read
 162                (format "%s (default %s) " prompt default)
 163                completions nil must-match)
 164             (read-string
 165              (format "%s (default %s) " prompt default))))
 166     (if (equal class-name "") default class-name)))
 167
 168 (defun br-find-class-name-as-list ()
 169   "Return a list composed of the class name that point is within in a listing buffer, else nil."
 170   (let ((class (br-find-class-name)))
 171     (if class (list class))))
 172
 173 (defun br-find-class-name (&optional keep-indent)
 174   "Return class name that point is within in a listing buffer, else nil.
 175 Optional KEEP-INDENT non-nil means keep indentation preceding class name."
 176   (if (= (point) (point-max)) (skip-chars-backward " \t\n\r"))
 177   (if (save-excursion
 178         (beginning-of-line)
 179         (not (looking-at (concat "[ \t]*" br-feature-type-regexp "[ \t]+"))))
 180       (save-excursion
 181         (skip-chars-forward " \t")
 182         (let ((objc (string-equal br-lang-prefix "objc-"))
 183               (java (string-equal br-lang-prefix "java-"))
 184               (class))
 185           (skip-chars-backward
 186            (cond (objc
 187                   ;; Include [] characters for default classes, <> for protocols
 188                   ;; and () for categories.
 189                   (concat "\]\[()<>" br-identifier-chars))
 190                  (java
 191                   ;; Include <> for interfaces.
 192                   (concat "\]\[<>" br-identifier-chars))
 193                  (t (concat "\]\[" br-identifier-chars))))
 194           (if (or (and java
 195                        ;; Java interface
 196                        (looking-at (concat "<" br-identifier ">")))
 197                   (and objc
 198                        (or
 199                         ;; Objective-C protocol
 200                         (looking-at (concat "<" br-identifier ">"))
 201                         ;; Objective-C class(category)
 202                         (looking-at (concat br-identifier "(" br-identifier ")"))
 203                         ;; Objective-C (category)class
 204                         (if (looking-at
 205                              (concat "\\((" br-identifier ")\\)" br-identifier))
 206                             (setq class (concat (br-buffer-substring
 207                                                  (match-end 1) (match-end 0))
 208                                                 (br-buffer-substring
 209                                                  (match-beginning 1)
 210                                                  (match-end 1)))))
 211                         ;; Objective-C (category)
 212                         (looking-at (concat "(" br-identifier ")"))))
 213                   (looking-at br-identifier)
 214                   ;; default class
 215                   (looking-at (concat "\\[" br-identifier "\\]")))
 216               (progn (if keep-indent (beginning-of-line))
 217                      (br-set-case (or class
 218                                       (br-buffer-substring (point)
 219                                                            (match-end 0))))))))))
 220
 221 (defun br-lisp-mode-p ()
 222   (or (eq major-mode 'lisp-mode)
 223       (eq major-mode 'emacs-lisp-mode)
 224       (eq major-mode 'scheme-mode)
 225       (eq major-mode 'lisp-interaction-mode)))
 226
 227 (defun br-complete-type ()
 228   "Perform in-buffer completion of a type or element identifier before point.
 229 That symbol is compared against current Environment entries and any needed
 230 characters are inserted."
 231   (interactive)
 232   (let* ((completion-ignore-case nil)
 233          (end (point))
 234          (beg (save-excursion
 235                 (if (br-lisp-mode-p)
 236                     nil
 237                   (skip-chars-backward "^()")
 238                   (if (eq (preceding-char) ?\()
 239                       (skip-chars-backward " \t\(")
 240                     (goto-char end))
 241                   )
 242                 (skip-chars-backward (concat br-identifier-chars ":"))
 243                 (point)))
 244          (pattern (br-set-case (br-buffer-substring beg end)))
 245          (type-p)
 246          (completion-alist (if (string-match br-feature-signature-regexp
 247                                              pattern)
 248                                (br-feature-completions)
 249                              (setq type-p t)
 250                              ;; Return class names plus default class
 251                              ;; elements without their class names.
 252                              (br-default-class-completions)))
 253          (completion (try-completion pattern completion-alist)))
 254     (cond ((eq completion t))
 255           ((null completion)
 256            (message "Can't find completion for `%s'" pattern)
 257            (ding))
 258           ((not (string-equal pattern completion))
 259            (delete-region beg end)
 260            (insert (if type-p
 261                        (br-set-case-type completion)
 262                      completion)))
 263           (t
 264            (message "Making completion list...")
 265            (let ((list (sort (all-completions pattern completion-alist)
 266                              'string-lessp)))
 267              (let (new)
 268                (while list
 269                  (setq new (cons (car list) new)
 270                        list (cdr list)))
 271                (setq list (nreverse new)))
 272              (with-output-to-temp-buffer "*Completions*"
 273                (display-completion-list list)))
 274            (message "Making completion list...%s" "done")))))
 275
 276 ;; Derived from saveconf.el.
 277 (defun br-window-list ()
 278   "Returns a list of Lisp window objects for all Emacs windows.
 279 Do not count the minibuffer window even if it is active."
 280   (let* ((first-window (next-window (previous-window (selected-window))))
 281          (windows (cons first-window nil))
 282          (current-cons windows)
 283          (w (next-window first-window)))
 284     (while (not (eq w first-window))
 285       (setq current-cons (setcdr current-cons (cons w nil)))
 286       (setq w (next-window w)))
 287     windows))
 288
 289 ;;; ************************************************************************
 290 ;;; Private functions
 291 ;;; ************************************************************************
 292
 293 (defun br-class-completions ()
 294   "Return alist of elements whose cars are all class names in lookup table."
 295   (mapcar (function (lambda (elt) (cons elt nil)))
 296           (sort (br-all-classes) 'string-lessp)))
 297
 298 (provide 'br-compl)