source: branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp @ 8062

Last change on this file since 8062 was 8062, checked in by gz, 13 years ago

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.0 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Written by Skef Wholey and Blaine Burks.
13;;; General idea stolen from Jim Salem's TMC LISPM completion code.
14;;;
15
16(in-package :hemlock)
17
18
19
20;;;; The Completion Database.
21
22;;; The top level structure here is an array that gets indexed with the
23;;; first three characters of the word to be completed.  That will get us to
24;;; a list of the strings with that prefix sorted in most-recently-used order.
25;;; The number of strings in any given bucket will never exceed
26;;; Completion-Bucket-Size-Limit.  Strings are stored in the database in
27;;; lowercase form always.
28
29(defconstant completion-table-size 991)
30
31(defvar *completions* (make-array completion-table-size :initial-element nil))
32
33(defhvar "Completion Bucket Size"
34  "This limits the number of completions saved for a particular combination of
35   the first three letters of any word."
36  :value 20)
37
38
39;;; Mapping strings into buckets.
40
41;;; The characters that are considered parts of "words" change from mode
42;;; to mode.
43;;;
44(defattribute "Completion Wordchar"
45  "1 for characters we consider to be constituents of words.")
46
47(defvar default-other-wordchars
48  '(#\- #\* #\' #\_))
49
50(do-alpha-chars (char :both)
51  (setf (character-attribute :completion-wordchar char) 1))
52
53(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
54  (setf (character-attribute :completion-wordchar char) 1))
55
56(dolist (char default-other-wordchars)
57  (setf (character-attribute :completion-wordchar char) 1))
58
59
60;;; The difference between Lisp mode and the other modes is pretty radical in
61;;; this respect.  These are interesting too, but they're on by default: #\*,
62;;; #\-, and #\_.  #\' is on by default too, but it's uninteresting in "Lisp"
63;;; mode.
64;;;
65(defvar default-lisp-wordchars
66  '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\< #\> #\. #\/ #\?))
67
68(dolist (char default-lisp-wordchars)
69  (shadow-attribute :completion-wordchar char 1 "Lisp"))
70
71(shadow-attribute :completion-wordchar #\' 0 "Lisp")
72
73(defmacro completion-char-p (char)
74  `(= (the fixnum (character-attribute :completion-wordchar ,char)) 1))
75
76;;; COMPLETION-BUCKET-FOR returns the Completion-Bucket that might hold a
77;;; completion for the given String.  With optional Value, sets the bucket.
78;;;
79(defun completion-bucket-for (string length &optional (value nil value-p))
80  (declare (simple-string string)
81           (fixnum length))
82  (when (and (>= length 3)
83             (completion-char-p (char string 0))
84             (completion-char-p (char string 1))
85             (completion-char-p (char string 2)))
86    (let ((index (mod (logxor (ash
87                               (logxor
88                                (ash (hi::search-hash-code (schar string 0))
89                                     5)
90                                (hi::search-hash-code (schar string 1)))
91                               3)
92                              (hi::search-hash-code (schar string 2)))
93                      completion-table-size)))
94      (declare (fixnum index))
95      (if value-p
96          (setf (svref *completions* index) value)
97          (svref *completions* index)))))
98
99(defsetf completion-bucket-for completion-bucket-for)
100
101
102;;; FIND-COMPLETION returns the most recent string matching the given
103;;; Prefix, or Nil if nothing appropriate is in the database.  We assume
104;;; the Prefix is passed to us in lowercase form so we can use String=.  If
105;;; we find something appropriate, we bring it to the front of the list.
106;;; Prefix-Length, if supplied restricts us to look at just the start of
107;;; the string...
108;;;
109(defun find-completion (prefix &optional (prefix-length (length prefix)))
110  (declare (simple-string prefix)
111           (fixnum prefix-length))
112  (let ((bucket (completion-bucket-for prefix prefix-length)))
113    (do ((list bucket (cdr list)))
114        ((null list))
115      (let ((completion (car list)))
116        (declare (simple-string completion))
117        (when (and (>= (length completion) prefix-length)
118                   (string= prefix completion
119                            :end1 prefix-length
120                            :end2 prefix-length))
121          (unless (eq list bucket)
122            (rotatef (car list) (car bucket)))
123          (return completion))))))
124
125;;; RECORD-COMPLETION saves string in the completion database as the first item
126;;; in the bucket, that's the most recently used completion.  If the bucket is
127;;; full, drop the oldest item in the list.  If string is already in the
128;;; bucket, simply move it to the front.  The way we move an element to the
129;;; front requires a full bucket to be at least three elements long.
130;;;
131(defun record-completion (string)
132  (declare (simple-string string))
133  (let ((string-length (length string)))
134    (declare (fixnum string-length))
135    (when (> string-length 3)
136      (let ((bucket (completion-bucket-for string string-length))
137            (limit (value completion-bucket-size)))
138        (do ((list bucket (cdr list))
139             (last nil list)
140             (length 1 (1+ length)))
141            ((null list)
142             (setf (completion-bucket-for string string-length)
143                   (cons string bucket)))
144          (cond ((= length limit)
145                 (setf (car list) string)
146                 (setf (completion-bucket-for string string-length) list)
147                 (setf (cdr list) bucket)
148                 (setf (cdr last) nil)
149                 (return))
150                ((string= string (the simple-string (car list)))
151                 (unless (eq list bucket)
152                   (rotatef (car list) (car bucket)))
153                 (return))))))))
154
155;;; ROTATE-COMPLETIONS rotates the completion bucket for the given Prefix.
156;;; We just search for the first thing in the bucket with the Prefix, then
157;;; move that to the end of the list.  If there ain't no such thing there,
158;;; or if it's already at the end, we do nothing.
159;;;
160(defun rotate-completions (prefix &optional (prefix-length (length prefix)))
161  (declare (simple-string prefix))
162  (let ((bucket (completion-bucket-for prefix prefix-length)))
163    (do ((list bucket (cdr list))
164         (prev nil list))
165        ((null list))
166      (let ((completion (car list)))
167        (declare (simple-string completion))
168        (when (and (>= (length completion) prefix-length)
169                   (string= prefix completion
170                            :end1 prefix-length :end2 prefix-length))
171          (when (cdr list)
172            (if prev
173                (setf (cdr prev) (cdr list))
174                (setf (completion-bucket-for prefix prefix-length) (cdr list)))
175            (setf (cdr (last list)) list)
176            (setf (cdr list) nil))
177          (return nil))))))
178
179
180
181;;;; Hemlock interface.
182
183(defmode "Completion" :transparent-p t :precedence 10.0
184  :documentation
185  "This is a minor mode that saves words greater than three characters in length,
186   allowing later completion of those words.  This is very useful for often
187   long identifiers used in Lisp code.  All words with the same first three
188   letters are in one list sorted by most recently used.  \"Completion Bucket
189   Size\" limits the number of completions saved in each list.")
190
191(defvar *completion-modeline-field* (modeline-field :completion))
192
193(defcommand "Completion Mode" (p)
194  "Toggles Completion Mode in the current buffer."
195  "Toggles Completion Mode in the current buffer."
196  (declare (ignore p))
197  (let ((buffer (current-buffer)))
198    (setf (buffer-minor-mode buffer "Completion")
199          (not (buffer-minor-mode buffer "Completion")))
200    (let ((fields (buffer-modeline-fields buffer)))
201      (if (buffer-minor-mode buffer "Completion")
202        (unless (member *completion-modeline-field* fields)
203          (hi::set-buffer-modeline-fields buffer
204                                          (append fields
205                                                  (list *completion-modeline-field*))))
206        (when (member *completion-modeline-field* fields)
207          (hi::set-buffer-modeline-fields buffer
208                                          (remove *completion-modeline-field*
209                                                  fields)))))))
210
211
212;;; Consecutive alphanumeric keystrokes that start a word cause a possible
213;;; completion to be displayed in the echo area's modeline, the status line.
214;;; Since most insertion is building up a word that was already started, we
215;;; keep track of the word in *completion-prefix* that the user is typing.  The
216;;; length of the thing is kept in *completion-prefix-length*.
217;;;
218(defconstant completion-prefix-max-size 100)
219
220(defvar *completion-prefix* (make-string completion-prefix-max-size))
221
222(defvar *completion-prefix-length* 0)
223
224
225;;; "Completion Self Insert" does different stuff depending on whether or
226;;; not the thing to be inserted is Completion-Char-P.  If it is, then we
227;;; try to come up with a possible completion, using Last-Command-Type to
228;;; tense things up a bit.  Otherwise, if Last-Command-Type says we were
229;;; just doing a word, then we record that word in the database.
230;;;
231(defcommand "Completion Self Insert" (p)
232  "Insert the last character typed, showing possible completions.  With prefix
233   argument insert the character that many times."
234  "Implements \"Completion Self Insert\". Calling this function is not
235   meaningful."
236  (let ((char (last-char-typed)))
237    (unless char (editor-error "Can't insert that character."))
238    (cond ((completion-char-p char)
239           ;; If start of word not already in *completion-prefix*, put it
240           ;; there.
241           (unless (eq (last-command-type) :completion-self-insert)
242             (set-completion-prefix))
243           ;; Then add new stuff.
244           (cond ((and p (> p 1))
245                  (fill *completion-prefix* (char-downcase char)
246                        :start *completion-prefix-length*
247                        :end (+ *completion-prefix-length* p))
248                  (incf *completion-prefix-length* p))
249                 (t
250                  (setf (schar *completion-prefix* *completion-prefix-length*)
251                        (char-downcase char))
252                  (incf *completion-prefix-length*)))
253           ;; Display possible completion, if any.
254           (display-possible-completion *completion-prefix*
255                                        *completion-prefix-length*)
256           (setf (last-command-type) :completion-self-insert))
257          (t
258           (when (eq (last-command-type) :completion-self-insert)
259             (record-completion (subseq *completion-prefix*
260                                        0 *completion-prefix-length*)))))))
261
262;;; SET-COMPLETION-PREFIX grabs any completion-wordchars immediately before
263;;; point and stores these into *completion-prefix*.
264;;;
265(defun set-completion-prefix ()
266  (let* ((point (current-point))
267         (point-line (mark-line point)))
268    (cond ((and (previous-character point)
269                (completion-char-p (previous-character point)))
270           (with-mark ((mark point))
271             (reverse-find-attribute mark :completion-wordchar #'zerop)
272             (unless (eq (mark-line mark) point-line)
273               (editor-error "No completion wordchars on this line!"))
274             (let ((insert-string (nstring-downcase
275                                   (region-to-string
276                                    (region mark point)))))
277               (replace *completion-prefix* insert-string)
278               (setq *completion-prefix-length* (length insert-string)))))
279          (t
280           (setq *completion-prefix-length* 0)))))
281
282
283(defcommand "Completion Complete Word" (p)
284  "Complete the word if we've got a completion, fixing up the case.  Invoking
285   this immediately in succession rotates through possible completions in the
286   buffer.  If there is no currently displayed completion, this tries to choose
287   a completion from text immediately before the point and displays the
288   completion if found."
289  "Complete the word if we've got a completion, fixing up the case."
290  (declare (ignore p))
291  (let ((last-command-type (last-command-type)))
292    ;; If the user has been cursoring around and then tries to complete,
293    ;; let him.
294    ;;
295    (unless (member last-command-type '(:completion-self-insert :completion))
296      (set-completion-prefix)
297      (setf last-command-type :completion-self-insert))
298    (case last-command-type
299      (:completion-self-insert
300       (do-completion))
301      (:completion
302       (rotate-completions *completion-prefix* *completion-prefix-length*)
303       (do-completion))))
304  (setf (last-command-type) :completion))
305
306(defcommand "List Possible Completions" (p)
307  "List all possible completions of the prefix the user has typed."
308  "List all possible completions of the prefix the user has typed."
309  (declare (ignore p))
310  (let ((last-command-type (last-command-type)))
311    (unless (member last-command-type '(:completion-self-insert :completion))
312      (set-completion-prefix))
313    (let* ((prefix *completion-prefix*)
314           (prefix-length *completion-prefix-length*)
315           (bucket (completion-bucket-for prefix prefix-length)))
316      (with-pop-up-display (s)
317        (dolist (completion bucket)
318          (when (and (> (length completion) prefix-length)
319                     (string= completion prefix
320                              :end1 prefix-length
321                              :end2 prefix-length))
322            (write-line completion s))))))
323  ;; Keep the redisplay hook from clearing any possibly displayed completion.
324  (setf (last-command-type) :completion-self-insert))
325
326(defvar *last-completion-mark* nil)
327
328(defun do-completion ()
329  (let ((completion (find-completion *completion-prefix*
330                                     *completion-prefix-length*))
331        (point (current-point)))
332    (when completion
333      (if *last-completion-mark*
334          (move-mark *last-completion-mark* point)
335          (setq *last-completion-mark* (copy-mark point :temporary)))
336      (let ((mark *last-completion-mark*))
337        (reverse-find-attribute mark :completion-wordchar #'zerop)
338        (let* ((region (region mark point))
339               (string (region-to-string region)))
340          (declare (simple-string string))
341          (delete-region region)
342          (let* ((first (position-if #'alpha-char-p string))
343                 (next (if first (position-if #'alpha-char-p string
344                                              :start (1+ first)))))
345            ;; Often completions start with asterisks when hacking on Lisp
346            ;; code, so we look for alphabetic characters.
347            (insert-string point
348                           ;; Leave the cascading IF's alone.
349                           ;; Writing this as a COND, using LOWER-CASE-P as
350                           ;; the test is not equivalent to this code since
351                           ;; numbers (and such) are nil for LOWER-CASE-P and
352                           ;; UPPER-CASE-P.
353                           (if (and first (upper-case-p (schar string first)))
354                               (if (and next
355                                        (upper-case-p (schar string next)))
356                                   (string-upcase completion)   
357                                   (word-capitalize completion))
358                               completion))))))))
359
360
361;;; WORD-CAPITALIZE is like STRING-CAPITALIZE except that it treats apostrophes
362;;; the Right Way.
363;;;
364(defun word-capitalize (string)
365  (let* ((length (length string))
366         (strung (make-string length)))
367    (do  ((i 0 (1+ i))
368          (new-word t))
369         ((= i length))
370      (let ((char (schar string i)))
371        (cond ((or (alphanumericp char)
372                   (char= char #\'))
373               (setf (schar strung i)
374                     (if new-word (char-upcase char) (char-downcase char)))
375               (setq new-word nil))
376              (t
377               (setf (schar strung i) char)
378               (setq new-word t)))))
379    strung))
380
381(defcommand "Completion Rotate Completions" (p)
382  "Show another possible completion in the status line, if there is one.
383   If there is no currently displayed completion, this tries to choose a
384   completion from text immediately before the point and displays the
385   completion if found.  With an argument, rotate the completion ring that many
386   times."
387  "Show another possible completion in the status line, if there is one.
388   With an argument, rotate the completion ring that many times."
389  (unless (eq (last-command-type) :completion-self-insert)
390    (set-completion-prefix)
391    (setf (last-command-type) :completion-self-insert))
392  (dotimes (i (or p 1))
393    (rotate-completions *completion-prefix* *completion-prefix-length*))
394  (display-possible-completion *completion-prefix* *completion-prefix-length*)
395  (setf (last-command-type) :completion-self-insert))
396
397
398;;;; Nifty database and parsing machanisms.
399
400(defhvar "Completion Database Filename"
401  "The file that \"Save Completions\" and \"Read Completions\" will
402   respectively write and read the completion database to and from."
403  :value nil)
404
405(defvar *completion-default-default-database-filename*
406  "hemlock-completions.txt"
407  "The file that will be defaultly written to and read from by \"Save
408   Completions\" and \"Read Completions\".")
409
410(defcommand "Save Completions" (p)
411  "Writes the current completion database to a file, defaultly the value of
412   \"Completion Database Filename\".  With an argument, prompts for a
413   filename."
414  "Writes the current completion database to a file, defaultly the value of
415   \"Completion Database Filename\".  With an argument, prompts for a
416   filename."
417  (let ((filename (or (and (not p) (value completion-database-filename))
418                      (prompt-for-file
419                       :must-exist nil
420                       :default *completion-default-default-database-filename*
421                       :prompt "File to write completions to: "))))
422    (with-open-file (s filename
423                       :direction :output
424                       :if-exists :rename-and-delete
425                       :if-does-not-exist :create)
426      (message "Saving completions...")
427      (dotimes (i (length *completions*))
428        (let ((bucket (svref *completions* i)))
429          (when bucket
430            (write i :stream s :base 10 :radix 10)
431            (write-char #\newline s)
432            (dolist (completion bucket)
433              (write-line completion s))
434            (terpri s))))
435      (message "Done."))))
436
437(defcommand "Read Completions" (p)
438  "Reads some completions from a file, defaultly the value of \"Completion
439   Database File\".  With an argument, prompts for a filename."
440  "Reads some completions from a file, defaultly the value of \"Completion
441   Database File\".  With an argument, prompts for a filename."
442  (let ((filename (or (and (not p) (value completion-database-filename))
443                      (prompt-for-file
444                       :must-exist nil
445                       :default *completion-default-default-database-filename*
446                       :prompt "File to read completions from: ")))
447        (index nil)
448        (completion nil))
449    (with-open-file (s filename :if-does-not-exist :error)
450      (message "Reading in completions...")
451      (loop
452        (let ((new-completions '()))
453          (unless (setf index (read-preserving-whitespace s nil nil))
454            (return))
455          ;; Zip past the newline that I know is directly after the number.
456          ;; All this to avoid consing.  I love it.
457          (read-char s)
458          (loop
459            (setf completion (read-line s))
460            (when (string= completion "") (return))
461            (unless (member completion (svref *completions* index))
462              (push completion new-completions)))
463          (let ((new-bucket (nconc (nreverse new-completions)
464                                            (svref *completions* index))))
465            (setf (svref *completions* index) new-bucket)
466            (do ((completion new-bucket (cdr completion))
467                 (end (1- (value completion-bucket-size)))
468                 (i 0 (1+ i)))
469                ((endp completion))
470              (when (= i end) (setf (cdr completion) nil))))))
471      (message "Done."))))
472
473(defcommand "Parse Buffer for Completions" (p)
474  "Zips over a buffer slamming everything that is a valid completion word
475   into the completion hashtable."
476  "Zips over a buffer slamming everything that is a valid completion word
477   into the completion hashtable."
478  (declare (ignore p))
479  (let ((buffer (prompt-for-buffer :prompt "Buffer to parse: "
480                                   :must-exist t
481                                   :default (current-buffer)
482                                   :default-string (buffer-name
483                                                    (current-buffer)))))
484    (with-mark ((word-start (buffer-start-mark buffer) :right-inserting)
485                (word-end (buffer-start-mark buffer) :left-inserting)
486                (buffer-end-mark (buffer-start-mark buffer)))
487      (message "Starting parse of ~S..." (buffer-name buffer))
488      (loop
489        (unless (find-attribute word-start :completion-wordchar) (return))
490        (record-completion
491         (region-to-string (region word-start
492                                   (or (find-attribute
493                                        (move-mark word-end word-start)
494                                        :completion-wordchar #'zerop)
495                                       buffer-end-mark))))
496        (move-mark word-start word-end))
497      (message "Done."))))
498
499
500
501;;;; Modeline hackery:
502
503(defvar *completion-mode-possibility* "")
504
505(defun display-possible-completion (prefix
506                                    &optional (prefix-length (length prefix)))
507  (let ((old *completion-mode-possibility*))
508    (setq *completion-mode-possibility*
509          (or (find-completion prefix prefix-length) ""))
510    (unless (eq old *completion-mode-possibility*)
511      (hi::note-modeline-change (current-buffer)))))
512
513(defun clear-completion-display ()
514  (unless (= (length (the simple-string *completion-mode-possibility*)) 0)
515    (setq *completion-mode-possibility* "")
516    (hi::note-modeline-change (current-buffer))))
517
518#|
519;;; COMPLETION-REDISPLAY-FUN erases any completion displayed in the status line.
520;;;
521(defun completion-redisplay-fun (window)
522  (declare (ignore window))
523  (unless (eq (last-command-type) :completion-self-insert)
524    (clear-completion-display)))
525(add-hook redisplay-hook #'completion-redisplay-fun)
526|#
Note: See TracBrowser for help on using the repository browser.