/[cmucl]/src/hemlock/completion.lisp
ViewVC logotype

Contents of /src/hemlock/completion.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5