source: trunk/source/cocoa-ide/hemlock/src/symbol-completion.lisp @ 8774

Last change on this file since 8774 was 8774, checked in by gz, 12 years ago

fix compiler warnings

File size: 15.7 KB
Line 
1;;; -*- Package: Hemlock -*-
2;;;
3;;; Copyright (c) 2007 Clozure Associates
4;;; This file is part of Clozure Common Lisp.
5;;;
6;;; Dynamic symbol completion
7;;; gz@clozure.com
8;;;
9;;; This uses wordchar attributes set up in completion.lisp, but otherwise is unrelated.
10
11(in-package :hemlock)
12
13;; Context maintained so repeated M-/'s can walk through all available abbreviations
14
15(defstruct (dabbrev-context (:conc-name "DABBREV."))
16  ;; The buffer this context belongs to
17  (buffer nil)
18  ;; The last expansion
19  (expansion nil)
20  ;; The thing that was expanded.  This is usually a prefix of expansion, but it might
21  ;; be initials (i.e. abbrev = mvb, expansion = multiple-value-bind).
22  (abbrev "" :type simple-string)
23  ;; The package prefix if any, including the ending colon(s).
24  (prefix nil)
25  ;; The position of the end of the expansion
26  (end-mark nil)
27  ;; buffer-signature as of the time the expansion was inserted.
28  (signature nil)
29  ;; list of expansions already tried and rejected
30  (seen ())
31  ;; List of places to try next
32  (state-path '(:before-point :after-point :other-buffers :this-package :other-packages))
33  ;; Sequence of sources to go thru before changing state
34  (sources '(:last-used))
35  ;; a sequence of expansions to go thru before changing source
36  (seq (make-array 10 :fill-pointer 0 :adjustable t)))
37
38(defun symbol-completion-buffer-hook (buffer)
39  (defhvar "DAbbrev Context"
40    "Internal variable for cycling through symbol completions"
41    :buffer buffer
42    :value nil)
43  (defhvar "DAbbrev Cache"
44    "Internal variable for caching symbols in buffer"
45    :buffer buffer
46    ;; Cons of buffer sig and a vector of all symbols in buffer as of the time
47    ;; of the buffer sig.
48    :value (cons nil nil))
49  )
50
51(add-hook make-buffer-hook #'symbol-completion-buffer-hook)
52
53;; Global table of all abbrevs expanded in this session, and the last value they expanded to.
54(defvar *dabbrevs* (make-hash-table :test #'equalp))
55
56(defun dabbrev-package (context)
57  (or (dabbrev-package-for-prefix (dabbrev.prefix context))
58      ;; TODO: look for in-package form preceeding point...
59      (buffer-package (dabbrev.buffer context))))
60
61(defun dabbrev-external-symbol-p (context)
62  ;; True if explicitly looking for an external symbol.
63  (let* ((prefix (dabbrev.prefix context))
64         (prefix-len (length prefix)))
65    (or (eql prefix-len 1)
66        (and (>= prefix-len 2)
67             (not (eql (aref prefix (- prefix-len 2)) #\:))))))
68
69(defun dabbrev-package-for-prefix (prefix)
70  (when prefix
71    (let* ((prefix-len (length prefix)))
72      (if (eql prefix-len 1)
73        ccl::*keyword-package*
74        (find-package (subseq prefix 0 (if (eql (aref prefix (- prefix-len 2)) #\:)
75                                         (- prefix-len 2)
76                                         (- prefix-len 1))))))))
77
78
79;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80;; State machine support:
81
82(defun dabbrev-next-expansion (context)
83  (cond ((> (length (dabbrev.seq context)) 0)
84         (let* ((exp (vector-pop (dabbrev.seq context))))
85           (if (find exp (dabbrev.seen context) :test #'string=)
86             (dabbrev-next-expansion context)
87             exp)))
88        ((dabbrev.sources context)
89         (dabbrev-collect-expansions (pop (dabbrev.sources context)) context)
90         (dabbrev-next-expansion context))
91        ((dabbrev.state-path context)
92         (setf (dabbrev.sources context)
93               (dabbrev-sources-in (pop (dabbrev.state-path context)) context))
94         (dabbrev-next-expansion context))
95        (t nil)))
96
97
98;; dabbrev-sources-in: maps state -> sources
99
100(defmethod dabbrev-sources-in ((state t) context)
101  (declare (ignore context))
102  (list state))
103
104(defmethod dabbrev-sources-in ((state (eql :other-buffers)) context)
105  (let* ((buffers (mapcar #'hemlock-view-buffer (hemlock-ext:all-hemlock-views))))
106    ;; Remove duplicates, always keeping the first occurance (frontmost window)
107    (loop for blist on buffers do (setf (cdr blist) (delete (car blist) (cdr blist))))
108    (delete (dabbrev.buffer context) buffers)))
109
110(defmethod dabbrev-sources-in ((state (eql :other-packages)) context)
111  (let* ((all (copy-list (list-all-packages)))
112         (this-package (dabbrev-package context))
113         (keyword-package ccl::*keyword-package*))
114    (setq all (delete this-package all))
115    (unless (eq this-package keyword-package)
116      (setq all (nconc (delete keyword-package all) (list keyword-package))))
117    all))
118
119;; dabbrev-collect-expansion: maps source -> expansions
120;; Note that in general these methods don't bother to check for dabbrev.seen
121;; or duplicates, even though they could, because there is no reason to spend
122;; time up front on checking expansions we might never get to.
123
124(defun dabbrev-match-p (context exp)
125  (let* ((abbrev (dabbrev.abbrev context))
126         (abbrev-len (length abbrev)))
127    (or (and (< abbrev-len (length exp))
128             (string-equal abbrev exp :end1 abbrev-len :end2 abbrev-len))
129        ;; Check for initials.
130        (loop
131          for char across abbrev
132          for pos = 0 then (and (setq pos (position-if-not #'alphanumericp exp :start pos))
133                                (position-if #'alphanumericp exp :start (1+ pos)))
134          always (and pos (char-equal char (aref exp pos)))))))
135
136(defmethod dabbrev-collect-expansions ((source (eql :last-used)) context)
137  (let* ((abbrev (dabbrev.abbrev context))
138         (prefix (dabbrev.prefix context))
139         (abbrev-len (length abbrev))
140         (prefix-len (length prefix))
141         (string (concatenate 'string abbrev prefix)))
142    (loop
143      for end from (+ abbrev-len prefix-len) downto prefix-len
144      for key = string then (subseq string 0 end)
145      as exp = (gethash key *dabbrevs*)
146      when (and exp (dabbrev-match-p context exp))
147      do (return (vector-push-extend exp (dabbrev.seq context))))))
148
149(defmethod dabbrev-collect-expansions ((buffer buffer) context)
150  ;; TODO: need to take prefix into account - give preferences to things
151  ;; matching prefix.  For now, ignore the prefix-only case here since can't
152  ;; do anything useful.
153  (unless (equal (dabbrev.abbrev context) "")
154    (let* ((vec (dabbrev-symbols-in-buffer buffer))
155           (seq (dabbrev.seq context)))
156      (loop
157        for exp across vec
158        when (dabbrev-match-p context exp)
159        do (vector-push-extend exp seq))
160      seq)))
161
162;; TODO: have a background process that does this. (Since the architecture doesn't allow locking
163;; against buffer changes, might need to do ignore-errors and just bludgeon through, checking
164;; for sig changes at end.  Or perhaps could use the modification hook, if that's reliable)
165(defun dabbrev-symbols-in-buffer (buffer)
166  (let* ((cache (variable-value 'dabbrev-cache :buffer buffer)))
167    (unless (and cache (eql (car cache) (buffer-signature buffer)))
168      (let* ((hi::*current-buffer* buffer)
169             (start-mark (buffer-start-mark buffer))
170             (symbols (make-array 100 :adjustable t :fill-pointer 0)))
171        (with-mark ((word-start start-mark)
172                    (word-end start-mark))
173          (loop
174            (unless (find-attribute word-end :completion-wordchar) (return))
175            (move-mark word-start word-end)
176            (unless (find-not-attribute word-end :completion-wordchar)
177              (buffer-end word-end))
178            (let* ((word (region-to-string (region word-start word-end))))
179              (unless (find word symbols :test #'equal)
180                (vector-push-extend word symbols)))))
181        (setf (variable-value 'dabbrev-cache :buffer buffer)
182              (setq cache (cons (buffer-signature buffer) (coerce symbols 'simple-vector))))))
183    (cdr cache)))
184
185(defun dabbrev-next-in-buffer (mark temp-mark temp-string)
186  ;; Leaves temp-mark at start and point-mark at end of next symbol
187  (when (find-attribute mark :completion-wordchar)
188    (move-mark temp-mark mark)
189    (unless (find-not-attribute mark :completion-wordchar)
190      (buffer-end mark))
191    (region-to-string (region temp-mark mark) temp-string)))
192
193(defun dabbrev-prev-in-buffer (mark temp-mark temp-string)
194  (when (reverse-find-attribute mark :completion-wordchar)
195    (move-mark temp-mark mark)
196    (unless (reverse-find-not-attribute mark :completion-wordchar)
197      (buffer-start mark))
198    (region-to-string (region mark temp-mark) temp-string)))
199
200(defmethod dabbrev-collect-expansions ((source (eql :before-point)) context)
201  (dabbrev-collect-expansions-1 source context))
202
203(defmethod dabbrev-collect-expansions ((source (eql :after-point)) context)
204  (dabbrev-collect-expansions-1 source context))
205
206(defun dabbrev-collect-expansions-1 (direction context)
207  (let* ((buffer (dabbrev.buffer context))
208         (point (buffer-point buffer))
209         (abbrev (dabbrev.abbrev context))
210         (abbrev-len (length abbrev))
211         (seq (dabbrev.seq context))
212         (temp-string (make-string 30)))
213    ;; TODO: need to take prefix into account - give preferences to things
214    ;; matching prefix.  For now, ignore the prefix-only case here since can't
215    ;; do anything useful.
216    (when (eql abbrev-len 0)
217      (return-from dabbrev-collect-expansions-1))
218    (with-mark ((mark point) (temp-mark point))
219      (when (eq direction :before-point) (character-offset mark (- abbrev-len)))
220      (loop
221        (multiple-value-bind (word word-len)
222                             (if (eq direction :before-point)
223                               (dabbrev-prev-in-buffer mark temp-mark temp-string)
224                               (dabbrev-next-in-buffer mark temp-mark temp-string))
225          (unless word (return))
226          (when (and (< abbrev-len word-len)
227                     (string-equal word abbrev :end1 abbrev-len :end2 abbrev-len))
228            (let* ((word (subseq word 0 word-len)))
229              (unless (find word seq :test #'equal)
230                (vector-push-extend word seq)))))))
231    (nreverse seq)))
232
233(defmethod dabbrev-collect-expansions ((source (eql :this-package)) context)
234  (let* ((pkg (dabbrev-package context))
235         (seq (dabbrev.seq context)))
236    (when pkg
237      (when (dabbrev.prefix context)
238        (if (or (dabbrev-external-symbol-p context)
239                (eq pkg ccl::*keyword-package*))
240          (do-external-symbols (sym pkg)
241            (when (and (not (find sym seq :test #'eq))
242                       (dabbrev-match-p context (symbol-name sym)))
243              (vector-push-extend sym seq)))
244          (ccl::do-present-symbols (sym pkg)
245            (when (and (not (find sym seq :test #'eq))
246                       (dabbrev-match-p context (symbol-name sym)))
247              (vector-push-extend sym seq)))))
248      (unless (eq pkg ccl::*keyword-package*)
249        (do-symbols (sym pkg)
250          (when (and (not (find sym seq :test #'eq))
251                     (dabbrev-match-p context (symbol-name sym)))
252            (vector-push-extend sym seq))))
253      (setq seq
254            (stable-sort seq #'(lambda (s1 s2)
255                                 (and (or (boundp s1) (fboundp s1))
256                                      (not (or (boundp s2) (fboundp s2)))))))
257      ;; Now convert to strings - and downcase for inserting in buffer.
258      (dotimes (i (length seq))
259        (setf (aref seq i) (string-downcase (symbol-name (aref seq i))))))
260    seq))
261
262(defmethod dabbrev-collect-expansions ((pkg package) context)
263  ;; For random packages, only need to do present symbols, since imported ones will be
264  ;; shown in their own package.
265  (let* ((seq (dabbrev.seq context)))
266    (ccl::do-present-symbols (sym pkg)
267      (let* ((name (symbol-name sym)))
268        (when (dabbrev-match-p context name)
269          (vector-push-extend (string-downcase name) seq))))
270    seq))
271
272;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
273;;
274;; the command
275
276
277(defcommand "Expand Dynamic Abbreviation" (p)
278  "Treats the symbol before point as an abbreviation and expands it.
279It checks the following in order until a suitable expansion is found:
280  - last accepted expansion for this abbreviation, if any
281  - symbols in current buffer before point
282  - symbols in current buffer after point
283  - symbols in all other editor windows, front to back
284  - symbols visible in the current package, fbound/bound symbols first
285  - symbols in all other packages (in no particular order)
286
287If called repeatedly from the same position, replaces the previous expansion
288with the next possible one.
289
290A symbol is a suitable expansion for an abbreviation if the abbreviation is
291a proper prefix of the symbol, or the abbreviation consists of the initials
292of the individual words within the symbol (e.g. mvb => multiple-value-bind).
293"
294  (declare (ignore p))
295  (let* ((buffer (current-buffer))
296         (point (buffer-point buffer))
297         (context (dabbrev-command-init buffer))
298         (abbrev (dabbrev.abbrev context))
299         (abbrev-len (length abbrev))
300         (expansion (dabbrev-next-expansion context))
301         (expansion-len (length expansion)))
302    (when (null expansion)
303      (editor-error "No~:[ more~] expansions for ~s"
304                    (null (dabbrev.expansion context))
305                    abbrev))
306    (push expansion (dabbrev.seen context))
307    (setf (dabbrev.expansion context) expansion)
308    (setf (gethash abbrev *dabbrevs*) expansion)
309    (if (and (>= expansion-len abbrev-len)
310             (string= abbrev expansion :end2 abbrev-len))
311      (insert-string point (subseq expansion abbrev-len))
312      (progn
313        (delete-characters point (- abbrev-len))
314        (insert-string point expansion)))
315    (move-mark (dabbrev.end-mark context) point)
316    (setf (dabbrev.signature context) (buffer-signature buffer))))
317
318#+gz ;; This tests the generation of completion candidates
319;; (time(hemlock::test-completions (cadr hi::*buffer-list*) "dabbrev"))
320(defun test-completions (buffer abbrev)
321  (let* ((hi::*current-buffer* buffer)
322         (point (buffer-point buffer))
323         (context (make-dabbrev-context
324                   :buffer buffer
325                   :abbrev abbrev
326                   ;; Can use a temp mark (i.e. the kind that doesn't automatically
327                   ;; update) because we only use it while buffer is unmodified.
328                   :end-mark (copy-mark point :temporary))))
329    (loop as expansion = (dabbrev-next-expansion context) while expansion
330      do (push expansion (dabbrev.seen context))
331      do (setf (dabbrev.expansion context) expansion)
332      do (setf (gethash abbrev *dabbrevs*) expansion))
333    (dabbrev.seen context)))
334
335;; Reinitialize context to either restart or cycle to next completion.
336;; In the latter case, undoes the last completion in the buffer.
337(defun dabbrev-command-init (buffer)
338  (let* ((point (buffer-point buffer))
339         (context (variable-value 'dabbrev-context :buffer buffer)))
340    (if (and context
341             ;; If buffer not modified since last time
342             (eql (dabbrev.signature context) (buffer-signature buffer))
343             ;; and cursor not moved elsewhere
344             (mark= (dabbrev.end-mark context) point))
345      ;; This means rejected previous attempt, get rid of it.
346      (let* ((abbrev (dabbrev.abbrev context))
347             (abbrev-len (length abbrev))
348             (expansion (dabbrev.expansion context))
349             (expansion-len (length expansion)))
350        ;; Sanity check, because I don't totally trust buffer-signature ...
351        (with-mark ((mark point))
352          (assert (and (character-offset mark (- (length expansion)))
353                       (equal (region-to-string (region mark point)) expansion))
354                  () "Bug! Buffer changed unexpectedly"))
355        (if (and (>= expansion-len abbrev-len)
356                 (string= abbrev expansion :end2 abbrev-len))
357          (delete-characters point (- abbrev-len expansion-len))
358          (progn
359            (delete-characters point (- expansion-len))
360            (insert-string point abbrev))))
361      ;; Else starting a new attempt, create a new context
362      (let* ((mark (copy-mark point :temporary)))
363        (multiple-value-bind (abbrev prefix) (dabbrev-get-abbrev mark point)
364          (when (and (equal abbrev "") (equal prefix ""))
365            (editor-error "Nothing to expand"))
366          (setq context (make-dabbrev-context
367                         :buffer buffer
368                         :abbrev abbrev
369                         :prefix prefix
370                         ;; Can use a temp mark (i.e. the kind that doesn't automatically
371                         ;; update) because we only use it while buffer is unmodified.
372                         :end-mark mark)))
373        (setf (variable-value 'dabbrev-context :buffer buffer) context)))
374    (move-mark (dabbrev.end-mark context) point)
375    context))
376
377(defun dabbrev-get-abbrev (mark point)
378  (declare (values abbrev package-prefix))
379  (move-mark mark point)
380  (unless (reverse-find-not-attribute mark :completion-wordchar)
381    (buffer-start mark))
382  (values (region-to-string (region mark point))
383          (when (eql (previous-character mark) #\:)
384            (with-mark ((temp mark))
385              (character-offset temp -1)
386              (when (eql (previous-character temp) #\:)
387                (character-offset temp -1))
388              (unless (reverse-find-not-attribute temp :completion-wordchar)
389                (buffer-start temp))
390              (region-to-string (region temp mark))))))
391
392
Note: See TracBrowser for help on using the repository browser.