source: trunk/source/contrib/repenning/anticipat-symbol-complete.lisp @ 12621

Last change on this file since 12621 was 12621, checked in by gz, 10 years ago

Anticipatory symbol completion contrib from Alex Repenning

File size: 28.9 KB
Line 
1;;; -*- package: ccl -*-
2;*********************************************************************
3;*                                                                   *
4;*    PROGRAM     A N T I C I P A T O R Y   SYMBOL COMPLETE          *
5;*                                                                   *
6;*********************************************************************
7   ;* Author    : Alexander Repenning (alexander@agentsheets.com)    *
8   ;*             http://www.agentsheets.com                         *
9   ;* Copyright : (c) 1996-2008, AgentSheets Inc.                    *
10   ;* Filename  : anticipatory-symbol-complete.lisp                  *
11   ;* Updated   : 12/30/08                                           *
12   ;* Version   :                                                    *
13   ;*   1.0     : 06/19/04                                           *
14   ;*   1.0.1   : 07/04/04 Peter Paine: custom -color*, nil wait     *
15   ;*   1.0.2   : 07/07/04 correct position for fred-dialog-item     *
16   ;*   1.1     : 09/08/04 don't get stuck; args and space on tab    *
17   ;*   1.1.1   : 09/09/04 use *Package* if Fred has no package      *
18   ;*   1.2     : 09/17/04 limited support Traps package, #_blabla   *
19   ;*                      cannot find unloaded traps (most)         *
20   ;*   1.3     : 09/29/04 save-exit function to be image friendly   *
21   ;*   1.4     : 10/06/04 play nice with Glen Foy's Color-Coded     *
22   ;*   1.4.1   : 10/21/04 handle $updateEvt                         *
23   ;*   1.4.2   : 12/14/04 XML "<..." and "</..." support            *
24   ;*   1.5     : 10/21/05 proactive typo alert                      *
25   ;*   1.5.1   : 08/25/06 use "..." instead of ellipsis char        *
26   ;*   1.5.2   : 09/22/06 works with LF EOL Fred buffers            *
27   ;*   1.5.3   : 08/14/07 symbol-completion-enabled-p method        *
28   ;*   1.5.4   : 10/24/07 handle Apple Events as kHighLevelEvent    *
29   ;*   2.0     : 04/22/08 Clozure CL, Gail Zacharias                *
30   ;*   2.0.1   : 04/25/08 auto enabled, release pool, process fix   *
31   ;*   2.0.2   : 12/30/08 kill processes when typing fast           *
32   ;* HW/SW     : G4,  CCL 1.2, OS X 10.5.2                          *
33   ;* Abstract  : Attempt symbol completion while user is typing.    *
34   ;*             #\tab to complete, show arglist if possible        *
35   ;*             #\esc to cancel                                    *
36   ;* Status    : good to go                                         *
37   ;* License   : LGPL                                               *
38   ;******************************************************************
39
40#+digitool (in-package :ccl)
41#+clozure (in-package :hemlock)
42
43(export '(symbol-completion-enabled-p *anticipatory-symbol-completion-enabled-p*))
44
45
46(defvar *Wait-Time-for-Anticipatory-Symbol-Complete* 0.2 "time in seconds to wait before anticipatory symbol complete begins to search.")
47
48(defvar *Anticipatory-Symbol-Completion-Enabled-p* t)
49
50(defvar *Anticipatory-Symbol-Completion-Font-Color* #+digitool *Gray-Color* #+clozure (#/grayColor ns:ns-color))
51
52(defvar *Anticipatory-Symbol-Completion-Background-Color*
53  #+digitool (make-color 55000 55000 64000)
54  #+clozure (gui::color-values-to-nscolor 55000/65535 55000/65535 64000/65535))
55
56(defvar *Zero-Completion-Hook* #+digitool #'ed-beep #+clozure #'beep "Call this function if there are no completions: could be the sign of a typo. Typically replace with more subtle sound.")
57
58;; Better enable these CCL compiler preferences to get more meaninglful arglists
59
60(eval-when (:compile-toplevel :load-toplevel :execute)
61  (unless ccl:*Save-Local-Symbols* (print "ANTICIPATORY SYMBOL COMPLETE hint: To get meaningful arglists for completed functions you should set ccl:*Save-Local-Symbols* to t"))
62  (unless ccl:*Fasl-Save-Local-Symbols* (print "ANTICIPATORY SYMBOL COMPLETE hint: To get meaningful arglists for completed functions you should set ccl:*Fasl-Save-Local-Symbols* to t")))
63
64;___________________________________
65; Completion Overlay Window         |
66;___________________________________
67
68(defvar *Assistant* nil)
69
70#+digitool (progn
71(defun COMPLETION-OVERLAY-WINDOW () "
72  Return current overlay window used for symbol completion.
73  Create one if needed."
74  (or *Assistant*
75      (setq *Assistant*
76            (rlet ((&window :pointer)
77                   (&rect :rect :topleft #@(100 100) :bottomright #@(500 140)))
78              (#_CreateNewWindow #$kOverlayWindowClass 0 &rect &window)
79              (%get-ptr &window)))))
80
81
82(defun WAIT-FOR-TIME-OR-KEY-EVENT (Time)
83  (let ((Wakeup-Time (+ (get-internal-real-time) (* Time internal-time-units-per-second))))
84    (without-interrupts   ;; don't allow other threads to steal events
85     (loop
86       ;; timeout
87       (when (>= (get-internal-real-time) Wakeup-Time) (return))
88       (when (mouse-down-p) (return))
89       ;; poll for key events
90       (rlet ((Event :eventrecord))
91         (when (#_EventAvail #$everyEvent Event)
92           (case (rref Event :eventrecord.what)
93             ((#.#$keyDown #.#$keyUp #.#$autoKey)  ;; Key Event
94              (let ((Char (code-char (logand #$charCodeMask (rref Event :eventrecord.message)))))
95                (unless (char= Char #\null)
96                  (return Char))))
97             ((#.#$activateEvt #.#$osEvt #.#$mouseDown #.#$mouseUp #.#$updateEvt)  ;; Window activation or OS event
98              (#_getNextEvent #$everyEvent Event))
99             ;; let OS X handle this Apple Event as high level event
100             ;; http://developer.apple.com/documentation/AppleScript/Conceptual/AppleEvents/dispatch_aes_aepg/chapter_4_section_3.html
101             ;; listing 3-5
102             (#.#$kHighLevelEvent
103              (#_AEProcessAppleEvent Event))
104             (t 
105              ;; unexpected event: send email to Alex if this happens
106              (ed-beep)
107              (format t "unexpected event=~A (send email to Alex)" (rref Event :eventrecord.what))))))))))
108
109
110(defun SHOW-IN-OVERLAY-WINDOW (Text Position) "
111  in:  Text string, Position point.
112  out: Char char.
113  Show <Text> in overlay window at screen <Position>.
114  Wait for key event or timeout.
115  In case of key event return char."
116  (let ((Window (completion-overlay-window)))
117    (#_MoveWindow Window (point-h Position) (point-v Position) t)
118    (#_ShowWindow window) 
119    (#_SetPort (#_GetWindowPort window))
120    ;; size of string?
121    (with-cfstrs ((string Text))
122      (rlet ((&ioBounds :point)
123             (&outBaseline :signed-integer))
124        (#_GetThemeTextDimensions 
125         String 
126         #$kThemeSmallSystemFont
127         #$kThemeStateActive
128         nil
129         &ioBounds
130         &outBaseline)
131        (let ((Text-Size (add-points (%get-point &ioBounds) #@(10 0))))
132          ;; paint background
133          (rlet ((&rect :rect :topleft #@(-10 1) :botright Text-Size))
134            (with-fore-color *Anticipatory-Symbol-Completion-Background-Color*
135              (#_PaintRoundRect &rect 12 12)))
136          ;; text
137          (rlet ((&rect :rect :topleft #@(1 0) :botright Text-Size))
138            (with-fore-color *Anticipatory-Symbol-Completion-Font-Color*
139              (#_DrawThemeTextBox
140               String
141               #$kThemeSmallSystemFont
142               #$kThemeStateActive
143               nil
144               &rect
145               #$teJustLeft
146               (%null-ptr)))))))
147    (#_QDFlushPortBuffer (#_GetWindowPort window) (%null-ptr))
148    (prog1
149      (wait-for-time-or-key-event 5)
150      (#_HideWindow window))))
151)
152
153#+clozure (progn
154(defclass completion-overlay (ns:ns-view)
155  ((text-attributes :foreign-type :id)
156   (text :foreign-type :id))
157  (:metaclass ns:+ns-object))
158
159(objc:defmethod (#/drawRect: :void) ((self completion-overlay) (rect :<NSR>ect))
160  (ccl::with-autorelease-pool 
161      (#/set (#/clearColor ns:ns-color))
162    (#_NSRectFill (#/bounds self))
163    (ns:with-ns-point (point 0 1)
164      (#/drawAtPoint:withAttributes: (slot-value self 'text)
165                                     point
166                                     (slot-value self 'text-attributes)))))
167
168(defun COMPLETION-OVERLAY-WINDOW () "
169  Return current overlay window used for symbol completion.
170  Create one if needed."
171  (or *Assistant*
172      (setq *Assistant*
173            (ns:with-ns-rect (frame 100 100 400 40)
174              (let* ((w (make-instance 'ns:ns-window
175                          :with-content-rect frame
176                          :style-mask #$NSBorderlessWindowMask
177                          :backing #$NSBackingStoreBuffered
178                          :defer #$YES))
179                     (view (make-instance 'completion-overlay
180                             :with-frame (#/frame (#/contentView w))))
181                     ;; Create attributes to use in window
182                     (attribs (make-instance 'ns:ns-mutable-dictionary :with-capacity 3)))
183                (#/setObject:forKey: attribs (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font))
184                                     #&NSFontAttributeName)
185                (#/setObject:forKey: attribs *Anticipatory-Symbol-Completion-Font-Color*
186                                     #&NSForegroundColorAttributeName)
187                (#/setObject:forKey: attribs *Anticipatory-Symbol-Completion-Background-Color*
188                                     #&NSBackgroundColorAttributeName)
189                (setf (slot-value view 'text-attributes) (#/retain attribs))
190                (setf (slot-value view 'text) (#/retain (gui::%make-nsstring "")))
191                (#/setContentView: w view)
192                ;; Set the background color to clear so that (along with the setOpaque call below)
193                ;; we can see through the parts of the window that we're not drawing into
194                (#/setBackgroundColor: w (#/clearColor ns:ns-color))
195                ;; No transparency for actual drawing into the window
196                (#/setAlphaValue: w (gui::cgfloat 1.0))
197                ;; Allow see through the parts of the window we're not drawing into
198                (#/setOpaque: w #$NO)
199                ;; Make it as unobtrusive as possible
200                (#/setIgnoresMouseEvents: w #$YES)
201                (#/setExcludedFromWindowsMenu: w #$YES)
202                (#/setHidesOnDeactivate: w #$YES)
203                w)))))
204
205
206(defun OPEN-OVERLAY-WINDOW (Text Position)
207  "Show text at screen position"
208  (ccl::with-autorelease-pool 
209      (let ((w (completion-overlay-window)))
210        (#/setFrameOrigin: w Position)
211        (let* ((w (completion-overlay-window))
212               (overlay (#/contentView w))
213               (nsstring (ccl::%make-nsstring Text)))
214          (with-slots (text) overlay
215            (#/release text)
216            (setf text (#/retain nsstring)))
217          (#/display w)
218          (#/orderFront: w ccl:+null-ptr+)))))
219
220(defun CLOSE-OVERLAY-WINDOW ()
221  "Hide the overlay window"
222  (let ((w (completion-overlay-window)))
223    (#/orderOut: w ccl:+null-ptr+)))
224)
225
226;___________________________________
227; Symbol String functions           |
228;___________________________________
229
230(defun COMMON-PREFIX (String1 String2)
231  ;; if one string is a complete substring then return it
232  (let ((Short-String (if (< (length String1) (length String2)) String1 String2)))
233    (dotimes (I (length Short-String) Short-String)
234      (let ((Char1 (char String1 i)))
235        (unless (char= Char1 (char String2 i))
236          (return (subseq Short-String 0 i)))))))
237   
238
239(defun LONGEST-PREFIX (Symbols)
240  (when Symbols
241    (reduce #'common-prefix (mapcar #'symbol-name Symbols))))
242
243
244;___________________________________
245; Cursor HPOS/VPOS Position fixes   |
246;___________________________________
247
248#+digitool
249(defmethod FRED-HPOS ((W listener-fred-item) &optional (Pos (buffer-position 
250                                                          (fred-buffer w))))
251  ;; Alice's listener HPOS fix
252  (let* ((Buf (fred-buffer w))
253         (Frec (frec w))
254         (End (buffer-line-end buf pos)))
255    (cond ((and (fr.wrap-p frec)
256                (eql end (buffer-size buf))
257                (> end 0))
258           (let* ((Start (buffer-line-start buf pos))
259                  (Res (%screen-line-hpos frec start pos end)))  ;; << was end end
260             ;(push (list res (fred-hpos w pos)) cow)
261             (+ res 0)))   ;; fudge epsilon
262          (t (fred-hpos w pos)))))
263
264
265#+digitool
266(defmethod FRED-HPOS ((Self fred-dialog-item) &optional (Pos (buffer-position (fred-buffer Self))))
267  ;; need to add dialog item in window offset
268  (declare (ignore Pos))
269  (+ (point-h (convert-coordinates #@(0 0) Self (view-window Self)))
270     (call-next-method)))
271
272
273#+digitool
274(defmethod FRED-VPOS ((Self fred-dialog-item) &optional (Pos (buffer-position (fred-buffer Self))))
275  ;; need to add dialog item in window offset
276  (declare (ignore Pos))
277  (+ (point-v (convert-coordinates #@(0 0) Self (view-window Self)))
278     (call-next-method)))
279
280;___________________________________
281; Completion-Request class          |
282;___________________________________
283
284(defclass COMPLETION-REQUEST ()
285  ((time-stamp :accessor time-stamp :initform (get-internal-real-time))
286   (completion-string :accessor completion-string :initform "" :initarg :completion-string)
287   (completion-name :accessor completion-name)
288   (completion-package :accessor completion-package)
289   #+clozure (completion-prefix :accessor completion-prefix :initform nil)
290   (fred-instance :accessor fred-instance :initarg :fred-instance)
291   (fred-buffer-start :accessor fred-buffer-start :initarg :fred-buffer-start)
292   (fred-buffer-end :accessor fred-buffer-end :initarg :fred-buffer-end))
293  (:documentation "captures what the request is, when it was made, and where is what made"))
294
295
296
297(defmethod INITIALIZE-INSTANCE :after ((Self completion-request) &rest Args)
298  (declare (ignore Args))
299  (let ((String (completion-string Self)))
300    ;; explore package clues
301    (when String
302      (setf (completion-name Self) 
303            (case (char String 0)
304              ((#\: #\#) (subseq (string-upcase String) 1))
305              (t (string-upcase String))))
306      (setf (completion-package Self) 
307            (or (and (char= (char String 0) #\:) (find-package :keyword))
308                (and (char= (char String 0) #\#) (find-package :traps))
309                #+digitool (window-package (fred-instance Self))
310                #+clozure (buffer-package (hemlock-view-buffer (fred-instance Self)))
311                *Package* )))))
312
313
314(defun ADD-SPECIAL-PACKAGE-PREFIX (String Package)
315  ;; some packages have a special prefix consisting of a single character
316  (cond
317   ((equal Package (find-package :keyword)) (format nil ":~A" String))
318   ((equal Package (find-package :traps)) (format nil "#~A" String))
319   (t String)))
320
321
322(defmethod PROMISING-PREFIX ((Thing string))
323  ;; heuristicly exclude
324  (and
325   (not (char-equal (char Thing 0) #\\))  ;; char names
326   (not (char-equal (char Thing 0) #\"))  ;; beginning of strings
327   (not (every ;; numbers
328         #'(lambda (Item)
329             (member Item '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\d #\D #\s #\S #\e #\E #\. #\/)))
330         Thing))))
331
332#+clozure
333(defmethod completion-screen-position ((Self completion-request))
334  (let* ((view (fred-instance Self))
335         (charpos (mark-absolute-position (buffer-point (hemlock-view-buffer view))))
336         (tv (gui::text-pane-text-view (hi::hemlock-view-pane view))))
337    (multiple-value-bind (x y) (gui::charpos-xy tv charpos)
338      (ns:with-ns-point (pt x (+ y (gui::text-view-line-height tv)))
339        (#/convertBaseToScreen: (#/window tv)
340                                (#/convertPoint:toView: tv pt gui::+null-ptr+))))))
341
342#+clozure
343(defmethod view-active-p ((Self completion-request))
344  (not (ccl:%null-ptr-p (#/window (hi::hemlock-view-pane (fred-instance Self))))))
345
346#+clozure
347(defvar *Completion-Request* nil "Currently active completion request")
348
349
350(defmethod ANTICIPATORY-SYMBOL-COMPLETE ((Self completion-request)) "
351  in: Completion-Request completion-request.
352  Explore the opportunity for symbol completion."
353  (ccl::with-autorelease-pool
354      ;; don't be too eager and wait first a little
355      (sleep *Wait-Time-for-Anticipatory-Symbol-Complete*)
356    ;; find matching symbols
357    (let* ((Local-Symbols (apropos-list (completion-name Self) (completion-package Self)))
358           (Symbols (matching-prefix-symbols (completion-name Self) Local-Symbols))
359           #+digitool (Fred (fred-instance Self)))
360      ;; proactive typo alert
361      (when (and *Zero-Completion-Hook*
362                 (= (length Local-Symbols) 0)
363                 (promising-prefix  (completion-name Self)))
364        (funcall *Zero-Completion-Hook*))  ;; beep when the number has dropped to zero: usually a sign of a typo
365      ;; completion attempt
366      (let ((Prefix (longest-prefix Symbols)))
367        (when (and (> (length Prefix) (length (completion-name Self)))
368                   #+digitool (and (view-window Fred) ;; window may be gone by now!
369                                   (wptr (view-window Fred)))
370                   #+clozure (view-active-p Self))
371          #+digitool (setq *Show-Cursor-P* nil)
372          ;; if we made it this far we better complete things
373          #+digitool
374          (let* ((Extension (string-downcase (subseq Prefix (length (completion-name Self)))))
375                 (Char (show-in-overlay-window
376                        (if (find-symbol Prefix (completion-package Self))
377                          Extension
378                          (format nil "~A..." Extension))
379                        (add-points (add-points (view-position (view-window Fred)) #@(0 -10))
380                                    (make-point (fred-hpos Fred) (fred-vpos Fred))))))
381            (case Char
382              ;; Tab = accept completion but don't do Fred indentation spiel
383              (#\tab
384               (#_FlushEvents (logior #$keyDownMask #$keyUpMask) 0)   ;; avoid indentation
385               (buffer-replace-string
386                Fred
387                (fred-buffer-start Self)
388                (fred-buffer-end Self)
389                (add-special-package-prefix Prefix (completion-package Self))
390                (completion-string Self))
391               (when (find-symbol Prefix (completion-package Self)) 
392                 (without-interrupts  ;; not sure this helps, found cases in which ed-arglist can hang MCL: WHY??
393                  (ed-arglist Fred)))  ;; show arglist if possible
394               (fred-update Fred))))
395          #+clozure
396          (let* ((Extension (string-downcase (subseq Prefix (length (completion-name Self))))))
397            (unwind-protect
398                (progn
399                  (open-overlay-window (if (find-symbol Prefix (completion-package Self))
400                                         Extension
401                                         (format nil "~A..." Extension))
402                                       (completion-screen-position Self))
403                  (setf (completion-prefix Self) Prefix)
404                  ;; If the user types anything while the window is up, this process gets reset with *Completion-Request*
405                  ;; still set, so the Tab command can tell what the Prefix was. 
406                  (setq *Completion-Request* Self)
407                  (sleep 5)
408                  ;; timed out: forget completion request
409                  (setq *Completion-Request* nil))
410              (close-overlay-window)) ))))))
411
412;___________________________________
413; Process Management                |
414;___________________________________
415
416(defvar *Completion-Process* nil "process used to complete symbols in anticipatory way")
417
418
419(defun COMPLETION-PROCESS ()
420  (or *Completion-Process*
421      (setq *Completion-Process* (ccl:make-process "Anticipatory Symbol Complete" :priority 0 #+digitool :quantum #+digitool 1))))
422
423
424#+digitool
425(defun START-SYMBOL-COMPLETE-PROCESS (Request)
426  (ccl::process-preset (completion-process) #'(lambda ()
427                                                (setq *Completion-Request* nil)
428                                                (anticipatory-symbol-complete Request)))
429  (ccl::process-reset-and-enable (completion-process)))
430
431#+clozure
432(defun START-SYMBOL-COMPLETE-PROCESS (Request)
433  (when *Completion-Process*
434    ;; not sure how we get here: before a new completion process is started
435    ;; the old should have been killed already
436    (ccl:process-kill *Completion-Process*))
437  (setq *Completion-Process*
438        (ccl::process-run-function 
439         '(:name "Anticipatory Symbol Complete" :priority 0)
440         #'(lambda () (anticipatory-symbol-complete Request)))))
441
442
443#+clozure
444(defun ABORT-SYMBOL-COMPLETE-PROCESS ()
445  (cond
446   ;; completion still going on
447   (*Completion-Process*
448    (ccl:process-kill *Completion-Process*)
449    (setq *Completion-Process* nil))
450   ;; completion must have timed out: remove completion request
451   (t
452    (setq *Completion-Request* nil))))
453
454;___________________________________
455; Symbol-Complete.lisp functions    |
456;___________________________________
457
458#+digitool
459(defmethod BUFFER-REPLACE-STRING ((Self fred-mixin) Start End String &optional Old-String) "
460  in:  Self {fred-mixin}, Start End {position}, String {string},
461       &optional Old-String {string}.
462  Delete the buffer content between <Start> and <End>, insert
463  <String> and place insertion marker to <End> position."
464  (let ((Mark (fred-buffer Self)))
465    (buffer-delete Mark Start End)
466    (buffer-insert 
467     Mark
468     (if Old-String
469       (case (string-format Old-String)
470         (:upper (string-upcase String))
471         (:lower (string-downcase String))
472         (:capital (string-capitalize String)))
473       String)))
474  ;; play nice with color-coded (when present)
475  (let ((Color-Code-Update-Function (find-symbol "DYNAMICALLY-STYLE-BUFFER" (find-package :cc))))
476    (when (fboundp Color-Code-Update-Function) (funcall Color-Code-Update-Function Self))))
477
478#+clozure
479(defun BUFFER-REPLACE-STRING (Start End String &optional Old-String) "
480  in: Start End {position}, String {string},
481       &optional Old-String {string}.
482  Delete the current buffer content between <Start> and <End>, insert
483  <String> and place insertion marker to <End> position."
484  (paste-characters Start (- End Start) 
485                    (if Old-String
486                      (case (string-format Old-String)
487                        (:upper (string-upcase String))
488                        (:lower (string-downcase String))
489                        (:capital (string-capitalize String)))
490                      String)))
491
492(defun STRING-FORMAT (String) "
493  in:  String {string}.
494  out: Capitalization {keyword} :upper, :lower :capital.
495  Return the capitalization status of a string"
496  (case (length String)
497    (0 :lower)
498    (1 (if (lower-case-p (char String 0)) :lower :upper))
499    (t (if (char= (char String 0) #\*)
500         (string-format (subseq String 1))
501         (if (upper-case-p  (char String 0))
502           (if (upper-case-p (char String 1))
503             :upper
504             :capital)
505           :lower)))))
506
507
508(defun MATCHING-PREFIX-SYMBOLS (String Symbols) "
509  in:  String {string}, Symbols {list of: {symbol}}.
510  out: Symbols {list of: {symbol}}.
511  Return only the symbols of which <String> is a prefix."
512  (let ((L (length String)))
513    (remove-if-not
514     #'(lambda (Symbol) (string= String (symbol-name Symbol) :end1 L :end2 L))
515     Symbols)))
516
517;___________________________________
518; FRED extensions                   |
519;___________________________________
520
521#+digitool
522(defun BUFFER-CURRENT-STRING (Buffer Position)
523  (when (< (buffer-size Buffer) 1) (return-from buffer-current-string))
524  (unless (char= (buffer-char Buffer Position) #\space)
525    (let ((Start Position)
526          (End Position)) 
527      ;; scan left for delimiter
528      (loop
529        (when (= Start 0) (return))
530        (case (buffer-char Buffer Start)
531          ((#\space #\return #\linefeed #\( #\) #\' #\<)
532           ;; special treatment for "<" versus "</" XML prefix
533           (return (incf Start (if (char= (buffer-char Buffer (1+ Start)) #\/) 2 1)))))
534        (decf Start))
535      ;; scan right for delimiter
536      (loop
537        (when (= End (buffer-size Buffer)) (return))
538        (incf End)
539        (case (buffer-char Buffer End)
540          ((#\space #\return #\linefeed #\( #\)) (return))))
541      (values
542       (buffer-substring Buffer Start End)
543       Start
544       End))))
545
546#+clozure
547(defun BUFFER-CURRENT-STRING ()
548  (with-mark ((Start (current-point))
549              (End (current-point)))
550    (unless (eq (previous-character Start) #\space)
551      ;; scan left for delimiter
552      (loop
553        (case (previous-character Start)
554          ((nil #\space #\tab #\return #\linefeed #\( #\) #\' #\<)
555           ;; special treatment for "<" versus "</" XML prefix
556           (when (eq (next-character start) #\/)
557             (mark-after Start))
558           (return)))
559        (mark-before Start))
560      ;; scan right for delimiter
561      (loop
562        (case (next-character End)
563          ((nil #\space #\tab #\return #\linefeed #\( #\)) (return)))
564        (mark-after End))
565      (values (region-to-string (region Start End))
566              (mark-absolute-position Start)
567              (mark-absolute-position End)))))
568
569#+digitool (progn
570
571(defmethod SYMBOL-COMPLETION-ENABLED-P ((Self fred-mixin))
572  t)
573
574
575(defmethod ED-INSERT-CHAR :after ((Self fred-mixin) Char) 
576  After typing a delimiter check if there is a link"
577  (unless (and *Anticipatory-Symbol-Completion-Enabled-P* (symbol-completion-enabled-p Self))
578    (return-from ed-insert-char))
579  (case Char
580    ;; user is done with current symbol: stop completion
581    ((#\space #\return)
582       (process-flush (completion-process)))
583    ;; new character part of current symbol
584    (t
585     (multiple-value-bind (String Start End)
586                          (buffer-current-string (fred-buffer Self) (- (buffer-position (fred-buffer Self)) 1))
587       (when (> (length String) 1)
588         (start-symbol-complete-process 
589          (make-instance 'completion-request 
590            :completion-string String
591            :fred-instance Self
592            :fred-buffer-start Start
593            :fred-buffer-end End)))))))
594)
595
596#+clozure (progn
597
598;; enable by default
599(add-hook make-buffer-hook
600                   #'(lambda (buffer)
601                       (setf (buffer-minor-mode buffer "Symbol Completion") t)))
602
603(defmode "Symbol Completion"
604  :documentation "This is a minor mode that provides anticipatory symbol completion")
605
606(defcommand "Symbol Completion Mode" (p)
607  "Toggles Symbol Completion mode in the current buffer"
608  (declare (ignore p))
609  (setf (buffer-minor-mode (current-buffer) "Symbol Completion")
610        (not (buffer-minor-mode (current-buffer) "Symbol Completion"))))
611
612(defhvar "Self Insert Command Name"
613  "Name of command to invoke for quoted insert in Symbol Completion mode"
614  :value "Self Insert With Symbol Completion"
615  :mode "Symbol Completion")
616
617(defcommand "Self Insert With Symbol Completion" (p)
618  "Self Insert and start up the completion process"
619  (self-insert-command p)
620  (when *Anticipatory-Symbol-Completion-Enabled-p*
621    (case (last-char-typed)
622      ((#\space #\newline) nil)
623      (t
624       (multiple-value-bind (String Start End) (buffer-current-string)
625         (when (> (length String) 1)
626           (handler-case (start-symbol-complete-process (make-instance 'completion-request
627                                                          :completion-string String
628                                                          :fred-instance (current-view)
629                                                          :fred-buffer-start start
630                                                          :fred-buffer-end end))
631             (t (Condition) (format t "condition: ~A" Condition)))))))))
632
633
634(dolist (c (command-bindings (getstring "Self Insert" *command-names*)))
635  (bind-key "Self Insert with Symbol Completion" (car c) :mode "Symbol Completion"))
636
637
638(defvar *Last-Hemlock-Key* nil "key last pressed in a hemlock view")
639
640
641(defmethod hi::execute-hemlock-key :before ((view hemlock-view) key)
642  (setq *Last-Hemlock-Key* Key)
643  (abort-symbol-complete-process))
644
645
646;; The :transparent-p flag causes this to do the usual binding for the key
647;; unless we explicitly invoke exit-event-handler.
648(defcommand ("Maybe Insert Symbol Completion" :transparent-p t) (p)
649  "Insert symbol completion if there is one, otherwise do the usual action"
650  (declare (ignore p))
651  (let* ((Request *Completion-Request*)
652         (Prefix (and Request (completion-prefix Request))))
653    (when Prefix
654      (buffer-replace-string (fred-buffer-start request)
655                             (fred-buffer-end request)
656                             (add-special-package-prefix Prefix (completion-package Request))
657                             (completion-string Request))
658      (when (find-symbol Prefix (completion-package Request))
659        (current-function-arglist-command nil))
660      (hi::exit-event-handler))))
661
662(bind-key "Maybe Insert Symbol Completion" #k"Tab" :mode "Symbol Completion")
663
664)
665
666;___________________________________
667; save-application support          |
668;___________________________________
669
670(defun ANTICIPATORY-SYMBOL-COMPLETE-SAVE-EXIT-FUNCTION ()
671  (setq *Assistant* nil)
672  (when *Completion-Process*
673    (ccl:process-kill *Completion-Process*)
674    (setq *Completion-Process* nil)))
675 
676
677(eval-when (:compile-toplevel :load-toplevel :execute)
678  (pushnew 'anticipatory-symbol-complete-save-exit-function ccl:*Save-Exit-Functions*))
679 
680
681#| Examples:
682
683(time (common-prefix "WITH-OPEN-FILE" "WITH-CLOSED-HOUSE"))
684
685(time (common-prefix "WITH-OPEN-FILE" "WITH-OPEN-FILENAME"))
686
687(time (common-prefix "WITH-OPEN-FILE" "WITH-OPEN-FILE"))
688
689
690
691|#
692
Note: See TracBrowser for help on using the repository browser.