Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-compl.el @ 0:376386a54a3c r19-14

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