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

Last change on this file since 12022 was 12022, checked in by rme, 11 years ago

Try to make the experimental apropos dialog work on Tiger.

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