source: branches/working-0711/ccl/cocoa-ide/apropos-window.lisp @ 7804

Last change on this file since 7804 was 7804, checked in by gb, 12 years ago

sync with trunk

File size: 8.2 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
6
7(defclass package-combo-box (ns:ns-combo-box)
8  ((packages :initform nil))
9  (:metaclass ns:+ns-object))
10
11;;; This is a premature optimization.  Instead of calling LIST-ALL-PACKAGES
12;;; so frequently, just get a fresh copy when the user clicks in the
13;;; combo box.
14(objc:defmethod (#/becomeFirstResponder :<BOOL>) ((self package-combo-box))
15  (with-slots (packages) self
16    (setf packages (coerce (list-all-packages) 'vector))
17    (setf packages (sort packages #'string-lessp :key #'package-name)))
18  (call-next-method))
19
20(defclass apropos-window-controller (ns:ns-window-controller)
21  ((apropos-array :foreign-type :id :initform +null-ptr+
22                  :reader apropos-array
23                  :documentation "Bound to NSArrayController in nib file")
24   (array-controller :foreign-type :id :accessor array-controller)
25   (combo-box :foreign-type :id :accessor combo-box)
26   (table-view :foreign-type :id :accessor table-view)
27   (text-view :foreign-type :id :accessor text-view)
28   (external-symbols-checkbox :foreign-type :id
29                              :accessor external-symbols-checkbox)
30   (shows-external-symbols :initform nil)
31   (symbol-list :initform nil)
32   (package :initform nil)
33   (input :initform nil)
34   (previous-input :initform nil :accessor previous-input
35                   :documentation "Last string entered"))
36  (:metaclass ns:+ns-object))
37
38(defmethod (setf apropos-array) (value (self apropos-window-controller))
39  (with-slots (apropos-array) self
40    (unless (eql value apropos-array)
41      (#/release apropos-array)
42      (setf apropos-array (#/retain value)))))
43
44;;; Diasable automatic KVO notifications, since having our class swizzled
45;;; out from underneath us confuses CLOS.  (Leopard doesn't hose us,
46;;; and we can use automatic KVO notifications there.)
47(objc:defmethod (#/automaticallyNotifiesObserversForKey: :<BOOL>) ((self +apropos-window-controller)
48                                                                  key)
49  (declare (ignore key))
50  nil)
51
52(objc:defmethod (#/awakeFromNib :void) ((self apropos-window-controller))
53  (with-slots (table-view text-view) self
54    (#/setString: text-view #@"")
55    (#/setDelegate: table-view self)
56    (#/setDoubleAction: table-view (@selector #/inspectSelectedSymbol:))))
57
58(objc:defmethod #/init ((self apropos-window-controller))
59  (prog1
60      (#/initWithWindowNibName: self #@"apropos")
61    (#/setShouldCascadeWindows: self nil)
62    (#/setWindowFrameAutosaveName: self #@"apropos panel")
63    (setf (apropos-array self) (#/array ns:ns-mutable-array))))
64
65(objc:defmethod (#/dealloc :void) ((self apropos-window-controller))
66  (#/release (slot-value self 'apropos-array))
67  (call-next-method))
68
69(objc:defmethod (#/toggleShowsExternalSymbols: :void)
70    ((self apropos-window-controller) sender)
71  (declare (ignore sender))
72  (with-slots (shows-external-symbols) self
73    (setf shows-external-symbols (not shows-external-symbols))
74    (update-symbol-list self)
75    (update-apropos-array self)))
76
77(objc:defmethod (#/setPackage: :void) ((self apropos-window-controller)
78                                       sender)
79  (with-slots (combo-box package) self
80    (assert (eql sender combo-box))
81    (with-slots (packages) sender
82      (let ((index (#/indexOfSelectedItem sender)))
83        (if (minusp index)
84          (setf package nil)            ;search all packages
85          (setf package (svref packages index))))))
86  (update-symbol-list self)
87  (update-apropos-array self))
88
89(defmethod update-symbol-list ((self apropos-window-controller))
90  (with-slots (input package shows-external-symbols symbol-list) self
91    (when (plusp (length input))
92      (setf symbol-list nil)
93      (if package
94        (if shows-external-symbols
95          (do-external-symbols (sym package)
96            (when (ccl::%apropos-substring-p input (symbol-name sym))
97              (push sym symbol-list)))
98          (do-symbols (sym package)
99            (when (ccl::%apropos-substring-p input (symbol-name sym))
100              (push sym symbol-list))))
101        (if shows-external-symbols
102          (dolist (p (list-all-packages))
103            (do-external-symbols (sym p)
104              (when (ccl::%apropos-substring-p input (symbol-name sym))
105                (push sym symbol-list))))
106          (do-all-symbols (sym)
107            (when (ccl::%apropos-substring-p input (symbol-name sym))
108              (push sym symbol-list)))))
109      (setf symbol-list (sort symbol-list #'string-lessp)))))
110
111(defmethod update-apropos-array ((self apropos-window-controller))
112  (with-slots (input apropos-array symbol-list package) self
113    (when (plusp (length input))
114      (let ((new-array (#/array ns:ns-mutable-array))
115            (*package* (or package (find-package "COMMON-LISP-USER")))
116            (n 0))
117        (dolist (s symbol-list)
118          (#/addObject: new-array (#/dictionaryWithObjectsAndKeys:
119                                   ns:ns-dictionary
120                                   (#/autorelease
121                                    (%make-nsstring
122                                     (prin1-to-string s)))
123                                   #@"symbol"
124                                   (#/numberWithInt: ns:ns-number n)
125                                   #@"index"
126                                   (#/autorelease
127                                    (%make-nsstring
128                                     (inspector::symbol-type-line s)))
129                                   #@"kind"
130                                   +null-ptr+))
131          (incf n))
132        (#/willChangeValueForKey: self #@"aproposArray")
133        (setf apropos-array new-array)
134        (#/didChangeValueForKey: self #@"aproposArray")))))
135
136(objc:defmethod (#/apropos: :void) ((self apropos-window-controller) sender)
137  (let* ((input (lisp-string-from-nsstring (#/stringValue sender))))
138    (when (and (plusp (length input))
139               (not (string-equal input (previous-input self))))
140      (setf (slot-value self 'input) input)
141      (setf (previous-input self) input)
142      (update-symbol-list self)
143      (update-apropos-array self))))
144
145(objc:defmethod (#/inspectSelectedSymbol: :void) ((self apropos-window-controller) sender)
146  (let* ((row (#/clickedRow sender)))
147    (unless (minusp row)
148      (with-slots (array-controller symbol-list) self
149        (let* ((number (#/valueForKeyPath: array-controller #@"selection.index"))
150               (i (#/intValue number))
151               (sym (elt symbol-list i)))
152          (cinspect sym))))))
153
154;;; Data source methods for package combo box
155
156(objc:defmethod (#/numberOfItemsInComboBox: :<NSI>nteger) ((self apropos-window-controller)
157                                                   combo-box)
158  (declare (ignore combo-box))
159  (length (list-all-packages)))
160
161(objc:defmethod #/comboBox:objectValueForItemAtIndex: ((self apropos-window-controller)
162                                                       combo-box
163                                                       (index :<NSI>nteger))
164  (with-slots (packages) combo-box
165    (let* ((pkg-name (package-name (svref packages index))))
166      (if pkg-name
167        (#/autorelease (%make-nsstring pkg-name))
168        +null-ptr+))))
169
170(objc:defmethod #/comboBox:completedString: ((self apropos-window-controller)
171                                             combo-box
172                                             partial-string)
173  (flet ((string-prefix-p (s1 s2)
174           "Is s1 a prefix of s2?"
175           (string-equal s1 s2 :end2 (min (length s1) (length s2)))))
176    (with-slots (packages) combo-box
177      (let* ((s (lisp-string-from-nsstring partial-string)))
178        (dotimes (i (length packages) +null-ptr+)
179          (let ((name (package-name (svref packages i))))
180            (when (string-prefix-p s name)
181              (return (#/autorelease (%make-nsstring name))))))))))
182
183(objc:defmethod (#/comboBox:indexOfItemWithStringValue: :<NSUI>nteger)
184    ((self apropos-window-controller)
185     combo-box
186     string)
187  (with-slots (packages) combo-box
188    (let* ((s (lisp-string-from-nsstring string)))
189      (or (position s packages :test #'(lambda (str pkg)
190                                         (string-equal str (package-name pkg))))
191          #$NSNotFound))))
192
193
194;;; Table view delegate methods
195
196(objc:defmethod (#/tableViewSelectionDidChange: :void) ((self apropos-window-controller)
197                                                        notification)
198  (with-slots (array-controller symbol-list text-view) self
199    (let* ((tv (#/object notification))
200           (row (#/selectedRow tv)))
201      (unless (minusp row)
202        (let* ((number (#/valueForKeyPath:
203                        array-controller #@"selection.index"))
204               (i (#/intValue number))
205               (sym (elt symbol-list i))
206               (info (make-array '(0) :element-type 'base-char
207                                 :fill-pointer 0 :adjustable t)))
208          (with-output-to-string (s info)
209            (dolist (doctype '(compiler-macro function method-combination
210                               setf structure t type variable))
211              (let ((docstring (documentation sym doctype)))
212                (when docstring
213                  (format s "~&~a" docstring))
214                (when (eq doctype 'function)
215                  (format s "~&arglist: ~s" (arglist sym))))))
216          (if (plusp (length info))
217            (#/setString: text-view (#/autorelease (%make-nsstring info)))
218            (#/setString: text-view #@"")))))))
219
220
Note: See TracBrowser for help on using the repository browser.