source: trunk/source/cocoa-ide/xapropos.lisp @ 13543

Last change on this file since 13543 was 13543, checked in by palter, 11 years ago

Cocotron r816 now implements some methods we use

File size: 9.6 KB
Line 
1(in-package "GUI")
2
3(defclass xapropos-window-controller (ns:ns-window-controller)
4  ((row-objects :foreign-type :id :reader row-objects)
5   (search-category :initform :all :accessor search-category)
6   (matched-symbols :initform (make-array 100 :fill-pointer 0 :adjustable t)
7                    :accessor matched-symbols)
8   (external-only-p :initform nil :accessor external-only-p)
9   ;; outlets
10   (action-menu :foreign-type :id :accessor action-menu)
11   (action-popup-button :foreign-type :id :accessor action-popup-button)
12   (search-field :foreign-type :id :accessor search-field)
13   (search-field-toolbar-item :foreign-type :id :accessor search-field-toolbar-item)
14   (all-symbols-button :foreign-type :id :accessor all-symbols-button)
15   (external-symbols-button :foreign-type :id :accessor external-symbols-button)
16   (table-view :foreign-type :id :accessor table-view)
17   (contextual-menu :foreign-type :id :accessor contextual-menu))
18  (:metaclass ns:+ns-object))
19
20(defclass scope-bar-view (ns:ns-view)
21  ()
22  (:metaclass ns:+ns-object))
23
24(defconstant $scope-bar-border-width 1)
25
26;;; This should use a gradient, but we don't have NSGradient on Tiger.
27
28(objc:defmethod (#/drawRect: :void) ((self scope-bar-view) (rect #>NSRect))
29  (let* (;;(start-color (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.75 1.0))
30         (end-color (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.90 1.0))
31         (border-color (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.69 1.0))
32         (bounds (#/bounds self)))
33    (#/set end-color)
34    (#_NSRectFill bounds)
35    (ns:with-ns-rect (r 0 0 (ns:ns-rect-width bounds) $scope-bar-border-width)
36      (#/set border-color)
37      (#_NSRectFill r))))
38
39(defconstant $all-symbols-item-tag 0)
40
41(defvar *apropos-categories*
42  '((0 . :all)
43    (1 . :function)
44    (2 . :variable)
45    (3 . :class)
46    (4 . :macro))
47  "Associates search menu item tags with keywords.")
48
49;;; action menu item tags
50(defconstant $inspect-item-tag 0)
51(defconstant $source-item-tag 1)
52
53(objc:defmethod #/init ((wc xapropos-window-controller))
54  (let ((self (#/initWithWindowNibName: wc #@"xapropos")))
55    (unless (%null-ptr-p self)
56      (setf (slot-value self 'row-objects) (make-instance 'ns:ns-mutable-array)))
57    self))
58
59(defun make-action-popup (menu)
60  (ns:with-ns-rect (r 0 0 44 23)
61    (let* ((button (make-instance 'ns:ns-pop-up-button :with-frame r :pulls-down t))
62           (item (#/itemAtIndex: menu 0))
63           (image-name (if (post-tiger-p) #@"NSActionTemplate" #@"gear")))
64      (#/setBezelStyle: button #$NSTexturedRoundedBezelStyle)
65      ;; This looks bad on Tiger: the arrow is in the bottom corner of the button.
66      #-cocotron                        ; no setArrowPosition
67      (#/setArrowPosition: (#/cell button) #$NSPopUpArrowAtBottom)
68      (#/setImage: item (#/imageNamed: ns:ns-image image-name))
69      (#/setMenu: button menu)
70      (#/synchronizeTitleAndSelectedItem button)
71      button)))
72
73(objc:defmethod (#/windowDidLoad :void) ((wc xapropos-window-controller))
74  (#/setDoubleAction: (table-view wc) (@selector #/inspect:))
75  (setf (action-popup-button wc) (make-action-popup (action-menu wc)))
76  (let* ((toolbar (make-instance 'ns:ns-toolbar :with-identifier #@"apropos toolbar")))
77    (#/setDisplayMode: toolbar #$NSToolbarDisplayModeIconOnly)
78    (#/setDelegate: toolbar wc)
79    (#/setToolbar: (#/window wc) toolbar)
80    (#/release toolbar)
81    (#/search: wc (search-field wc))
82    (#/makeFirstResponder: (#/window wc) (search-field wc))))
83
84(objc:defmethod #/toolbarAllowedItemIdentifiers: ((wc xapropos-window-controller) toolbar)
85  (declare (ignore toolbar))
86  (#/arrayWithObjects: ns:ns-array #@"action-popup-button"
87                       #&NSToolbarFlexibleSpaceItemIdentifier #@"search-field" +null-ptr+))
88
89(objc:defmethod #/toolbarDefaultItemIdentifiers: ((wc xapropos-window-controller) toolbar)
90  (declare (ignore toolbar))
91  (#/arrayWithObjects: ns:ns-array #@"action-popup-button"
92                       #&NSToolbarFlexibleSpaceItemIdentifier #@"search-field" +null-ptr+))
93
94(objc:defmethod #/toolbar:itemForItemIdentifier:willBeInsertedIntoToolbar:
95                ((wc xapropos-window-controller) toolbar identifier (flag #>BOOL))
96  (declare (ignore toolbar))
97  (let* ((toolbar-item (make-instance 'ns:ns-toolbar-item :with-item-identifier identifier)))
98    (#/autorelease toolbar-item)
99    (with-slots (action-popup-button search-field) wc
100      (cond ((#/isEqualToString: identifier #@"action-popup-button")
101             (#/setMinSize: toolbar-item (pref (#/frame action-popup-button) #>NSRect.size))
102             (#/setMaxSize: toolbar-item (pref (#/frame action-popup-button) #>NSRect.size))
103             (#/setView: toolbar-item action-popup-button))
104            ((#/isEqualToString: identifier #@"search-field")
105             (#/setMinSize: toolbar-item (pref (#/frame search-field) #>NSRect.size))
106             (#/setMaxSize: toolbar-item (pref (#/frame search-field) #>NSRect.size))
107             (#/setView: toolbar-item search-field))
108          (t
109           (setq toolbar-item +null-ptr+))))
110    toolbar-item))
111
112(objc:defmethod (#/dealloc :void) ((wc xapropos-window-controller))
113  (#/release (slot-value wc 'row-objects))
114  (call-next-method))
115
116(objc:defmethod (#/search: :void) ((wc xapropos-window-controller) sender)
117  (let* ((substring (#/stringValue sender)))
118    ;;(#_NSLog #@"search for %@" :id substring)
119    (apropos-search wc (lisp-string-from-nsstring substring))))
120
121(defun apropos-search (wc substring)
122  (with-accessors ((v matched-symbols)
123                   (category search-category)
124                   (array row-objects)) wc
125    (setf (fill-pointer v) 0)
126    (flet ((maybe-include-symbol (sym)
127             (when (case category
128                     (:function (fboundp sym))
129                     (:variable (boundp sym))
130                     (:macro (macro-function sym))
131                     (:class (find-class sym nil))
132                     (t t))
133               (when (ccl::%apropos-substring-p substring (symbol-name sym))
134                 (vector-push-extend sym v)))))
135      (if (external-only-p wc)
136        (dolist (p (list-all-packages))
137          (do-external-symbols (sym p)
138            (maybe-include-symbol sym)))
139        (do-all-symbols (sym)
140          (maybe-include-symbol sym))))
141    (setf v (sort v #'string-lessp))
142    (#/removeAllObjects array)
143    (let ((n (#/null ns:ns-null)))
144      (dotimes (i (length v))
145        (#/addObject: array n))))
146  (#/reloadData (table-view wc)))
147
148(objc:defmethod (#/setSearchCategory: :void) ((wc xapropos-window-controller) sender)
149  (let* ((tag (#/tag sender))
150         (label (if (= tag $all-symbols-item-tag)
151                  #@"Search"
152                  (#/stringWithFormat: ns:ns-string #@"Search (%@)" (#/title sender))))
153         (pair (assoc tag *apropos-categories*)))
154    (when pair
155      (let* ((items (#/itemArray (#/menu sender))))
156        (dotimes (i (#/count items))
157          (#/setState: (#/objectAtIndex: items i) #$NSOffState)))
158      (#/setState: sender #$NSOnState)
159      (#/setLabel: (search-field-toolbar-item wc) label)
160      (setf (search-category wc) (cdr pair))
161      (#/search: wc (search-field wc)))))
162
163(objc:defmethod (#/toggleExternalOnly: :void) ((wc xapropos-window-controller) sender)
164  (cond ((eql sender (all-symbols-button wc))
165         (#/setState: (external-symbols-button wc) #$NSOffState)
166         (setf (external-only-p wc) nil))
167        ((eql sender (external-symbols-button wc))
168         (#/setState: (all-symbols-button wc) #$NSOffState)
169         (setf (external-only-p wc) t)))
170  (#/search: wc (search-field wc)))
171 
172(objc:defmethod (#/inspect: :void) ((wc xapropos-window-controller) sender)
173  (declare (ignore sender))
174  (let* ((row (#/selectedRow (table-view wc)))
175         (clicked-row (#/clickedRow (table-view wc))))
176    (when (/= clicked-row -1)
177      (setq row clicked-row))
178    (inspect (aref (matched-symbols wc) row))))
179
180(objc:defmethod (#/source: :void) ((wc xapropos-window-controller) sender)
181  (declare (ignore sender))
182  (let* ((row (#/selectedRow (table-view wc)))
183         (clicked-row (#/clickedRow (table-view wc))))
184    (when (/= clicked-row -1)
185      (setq row clicked-row))
186    (hemlock::edit-definition (aref (matched-symbols wc) row))))
187
188(objc:defmethod (#/validateMenuItem: #>BOOL) ((wc xapropos-window-controller) menu-item)
189  (cond ((or (eql (action-menu wc) (#/menu menu-item))
190             (eql (contextual-menu wc) (#/menu menu-item)))
191         (let ((row (#/selectedRow (table-view wc)))
192               (clicked-row (#/clickedRow (table-view wc)))
193               (tag (#/tag menu-item)))
194           (when (/= clicked-row -1)
195             (setq row clicked-row))
196           (when (/= row -1)
197             (cond ((= tag $inspect-item-tag) t)
198                   ((= tag $source-item-tag)
199                    (let ((sym (aref (matched-symbols wc) row)))
200                      (edit-definition-p sym)))
201                   (t nil)))))
202        (t t)))
203
204(objc:defmethod (#/numberOfRowsInTableView: #>NSInteger) ((wc xapropos-window-controller)
205                                                          table-view)
206  (declare (ignore table-view))
207  (length (matched-symbols wc)))
208
209(objc:defmethod #/tableView:objectValueForTableColumn:row: ((wc xapropos-window-controller)
210                                                            table-view table-column
211                                                            (row #>NSInteger))
212  (declare (ignore table-view table-column))
213  (with-accessors ((array row-objects)
214                   (syms matched-symbols)) wc
215    (when (eql (#/objectAtIndex: array row) (#/null ns:ns-null))
216      (let ((name (%make-nsstring (prin1-to-string (aref syms row)))))
217        (#/replaceObjectAtIndex:withObject: array row name)
218        (#/release name)))
219    (#/objectAtIndex: array row)))
Note: See TracBrowser for help on using the repository browser.