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

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

Merge of the 'event-ide' branch. Hemlock's thread model has been changed
so that Hemlock commands now run in the Cocoa event thread -- see the
Hemlock file view.lisp for an overview.

IDE compilation has also been reorganized. Hemlock is now more fully
integrated into the IDE and cannot be compiled separately, sorry.

The hemlock-ext package has been repurposed to contain all interfaces
to window-system specific functionality.

There are also many many assorted other changes, cleanups and fixes.

The Hemlock documentation (Hemlock Command Implementor's Manual) in
http://trac.clozure.com/openmcl/wiki now correctly reflects the
implementation, although it doesn't (yet) describe the integration
with Cocoa or the threading model.

File size: 15.6 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      (stable-sort seq #'(lambda (s1 s2)
254                           (and (or (boundp s1) (fboundp s1))
255                                (not (or (boundp s2) (fboundp s2))))))
256      ;; Now convert to strings - and downcase for inserting in buffer.
257      (dotimes (i (length seq))
258        (setf (aref seq i) (string-downcase (symbol-name (aref seq i))))))
259    seq))
260
261(defmethod dabbrev-collect-expansions ((pkg package) context)
262  ;; For random packages, only need to do present symbols, since imported ones will be
263  ;; shown in their own package.
264  (let* ((seq (dabbrev.seq context)))
265    (ccl::do-present-symbols (sym pkg)
266      (let* ((name (symbol-name sym)))
267        (when (dabbrev-match-p context name)
268          (vector-push-extend (string-downcase name) seq))))
269    seq))
270
271;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
272;;
273;; the command
274
275
276(defcommand "Expand Dynamic Abbreviation" (p)
277  "Treats the symbol before point as an abbreviation and expands it.
278It checks the following in order until a suitable expansion is found:
279  - last accepted expansion for this abbreviation, if any
280  - symbols in current buffer before point
281  - symbols in current buffer after point
282  - symbols in all other editor windows, front to back
283  - symbols visible in the current package, fbound/bound symbols first
284  - symbols in all other packages (in no particular order)
285
286If called repeatedly from the same position, replaces the previous expansion
287with the next possible one.
288
289A symbol is a suitable expansion for an abbreviation if the abbreviation is
290a proper prefix of the symbol, or the abbreviation consists of the initials
291of the individual words within the symbol (e.g. mvb => multiple-value-bind).
292"
293  (declare (ignore p))
294  (let* ((buffer (current-buffer))
295         (point (buffer-point buffer))
296         (context (dabbrev-command-init buffer))
297         (abbrev (dabbrev.abbrev context))
298         (abbrev-len (length abbrev))
299         (expansion (dabbrev-next-expansion context))
300         (expansion-len (length expansion)))
301    (when (null expansion)
302      (editor-error "No~:[ more~] expansions for ~s"
303                    (null (dabbrev.expansion context))
304                    abbrev))
305    (push expansion (dabbrev.seen context))
306    (setf (dabbrev.expansion context) expansion)
307    (setf (gethash abbrev *dabbrevs*) expansion)
308    (if (and (>= expansion-len abbrev-len)
309             (string= abbrev expansion :end2 abbrev-len))
310      (insert-string point (subseq expansion abbrev-len))
311      (progn
312        (delete-characters point (- abbrev-len))
313        (insert-string point expansion)))
314    (move-mark (dabbrev.end-mark context) point)
315    (setf (dabbrev.signature context) (buffer-signature buffer))))
316
317#+gz ;; This tests the generation of completion candidates
318;; (time(hemlock::test-completions (cadr hi::*buffer-list*) "dabbrev"))
319(defun test-completions (buffer abbrev)
320  (let* ((hi::*current-buffer* buffer)
321         (point (buffer-point buffer))
322         (context (make-dabbrev-context
323                   :buffer buffer
324                   :abbrev abbrev
325                   ;; Can use a temp mark (i.e. the kind that doesn't automatically
326                   ;; update) because we only use it while buffer is unmodified.
327                   :end-mark (copy-mark point :temporary))))
328    (loop as expansion = (dabbrev-next-expansion context) while expansion
329      do (push expansion (dabbrev.seen context))
330      do (setf (dabbrev.expansion context) expansion)
331      do (setf (gethash abbrev *dabbrevs*) expansion))
332    (dabbrev.seen context)))
333
334;; Reinitialize context to either restart or cycle to next completion.
335;; In the latter case, undoes the last completion in the buffer.
336(defun dabbrev-command-init (buffer)
337  (let* ((point (buffer-point buffer))
338         (context (variable-value 'dabbrev-context :buffer buffer)))
339    (if (and context
340             ;; If buffer not modified since last time
341             (eql (dabbrev.signature context) (buffer-signature buffer))
342             ;; and cursor not moved elsewhere
343             (mark= (dabbrev.end-mark context) point))
344      ;; This means rejected previous attempt, get rid of it.
345      (let* ((abbrev (dabbrev.abbrev context))
346             (abbrev-len (length abbrev))
347             (expansion (dabbrev.expansion context))
348             (expansion-len (length expansion)))
349        ;; Sanity check, because I don't totally trust buffer-signature ...
350        (with-mark ((mark point))
351          (assert (and (character-offset mark (- (length expansion)))
352                       (equal (region-to-string (region mark point)) expansion))
353                  () "Bug! Buffer changed unexpectedly"))
354        (if (and (>= expansion-len abbrev-len)
355                 (string= abbrev expansion :end2 abbrev-len))
356          (delete-characters point (- abbrev-len expansion-len))
357          (progn
358            (delete-characters point (- expansion-len))
359            (insert-string point abbrev))))
360      ;; Else starting a new attempt, create a new context
361      (let* ((mark (copy-mark point :temporary)))
362        (multiple-value-bind (abbrev prefix) (dabbrev-get-abbrev mark point)
363          (when (and (equal abbrev "") (equal prefix ""))
364            (editor-error "Nothing to expand"))
365          (setq context (make-dabbrev-context
366                         :buffer buffer
367                         :abbrev abbrev
368                         :prefix prefix
369                         ;; Can use a temp mark (i.e. the kind that doesn't automatically
370                         ;; update) because we only use it while buffer is unmodified.
371                         :end-mark mark)))
372        (setf (variable-value 'dabbrev-context :buffer buffer) context)))
373    (move-mark (dabbrev.end-mark context) point)
374    context))
375
376(defun dabbrev-get-abbrev (mark point)
377  (declare (values abbrev package-prefix))
378  (move-mark mark point)
379  (unless (reverse-find-not-attribute mark :completion-wordchar)
380    (buffer-start mark))
381  (values (region-to-string (region mark point))
382          (when (eql (previous-character mark) #\:)
383            (with-mark ((temp mark))
384              (character-offset temp -1)
385              (when (eql (previous-character temp) #\:)
386                (character-offset temp -1))
387              (unless (reverse-find-not-attribute temp :completion-wordchar)
388                (buffer-start temp))
389              (region-to-string (region temp mark))))))
390
391
Note: See TracBrowser for help on using the repository browser.