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

Last change on this file since 11991 was 11991, checked in by rme, 10 years ago

Add an Experiments menu. The idea is that this menu will include,
er, experimental stuff.

The first experiment: a redesigned and simplified apropos dialog.

At the moment, this code won't work on Tiger. Tiger users will
get an error if they to pick anything from the Experiments menu.
(The IDE should still load, though, thanks to a kludge in the
BUILD-IDE function.)

File size: 5.3 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   (search-field :foreign-type :id :accessor search-field)
11   (search-field-toolbar-item :foreign-type :id :accessor search-field-toolbar-item)
12   (table-view :foreign-type :id :accessor table-view)
13   (contextual-menu :foreign-type :id :accessor contextual-menu))
14  (:metaclass ns:+ns-object))
15
16(defconstant $all-symbols-item-tag 0)
17
18(defvar *apropos-categories*
19  '((0 . :all)
20    (1 . :function)
21    (2 . :variable)
22    (3 . :class)
23    (4 . :macro))
24  "Associates search menu item tags with keywords.")
25
26;;; action menu item tags
27(defconstant $inspect-item-tag 0)
28(defconstant $source-item-tag 1)
29
30(objc:defmethod #/init ((wc xapropos-window-controller))
31  (let ((self (#/initWithWindowNibName: wc #@"xapropos")))
32    (unless (%null-ptr-p self)
33      (setf (slot-value self 'row-objects) (make-instance'ns:ns-mutable-array)))
34    self))
35
36(objc:defmethod (#/windowDidLoad :void) ((wc xapropos-window-controller))
37  (#/setDoubleAction: (table-view wc) (@selector #/inspect:)))
38
39(objc:defmethod (#/dealloc :void) ((wc xapropos-window-controller))
40  (#/release (slot-value wc 'row-objects))
41  (call-next-method))
42
43(objc:defmethod (#/search: :void) ((wc xapropos-window-controller) sender)
44  (let* ((substring (#/stringValue sender)))
45    ;;(#_NSLog #@"search for %@" :id substring)
46    (apropos-search wc (lisp-string-from-nsstring substring))))
47
48(defun apropos-search (wc substring)
49  (with-accessors ((v matched-symbols)
50                   (category search-category)
51                   (array row-objects)) wc
52    (setf (fill-pointer v) 0)
53    (do-all-symbols (sym)
54      (when (case category
55              (:function (fboundp sym))
56              (:variable (boundp sym))
57              (:macro (macro-function sym))
58              (:class (find-class sym nil))
59              (t t))
60        (when (ccl::%apropos-substring-p substring (symbol-name sym))
61          (vector-push-extend sym v))))
62    (setf v (sort v #'string-lessp))
63    (#/removeAllObjects array)
64    (dotimes (i (length v))
65      (let ((n (#/null ns:ns-null)))
66        (#/addObject: array n))))
67  (#/reloadData (table-view wc)))
68
69(objc:defmethod (#/setSearchCategory: :void) ((wc xapropos-window-controller) sender)
70  (let* ((tag (#/tag sender))
71         (label (if (= tag $all-symbols-item-tag)
72                  #@"Search"
73                  (#/stringWithFormat: ns:ns-string #@"Search (%@)" (#/title sender))))
74         (pair (assoc tag *apropos-categories*)))
75    (when pair
76      (let* ((items (#/itemArray (#/menu sender))))
77        (dotimes (i (#/count items))
78          (#/setState: (#/objectAtIndex: items i) #$NSOffState)))
79      (#/setState: sender #$NSOnState)
80      (#/setLabel: (search-field-toolbar-item wc) label)
81      (setf (search-category wc) (cdr pair))
82      (#/search: wc (search-field wc)))))
83
84(objc:defmethod (#/inspect: :void) ((wc xapropos-window-controller) sender)
85  (declare (ignore sender))
86  (let* ((row (#/selectedRow (table-view wc)))
87         (clicked-row (#/clickedRow (table-view wc))))
88    (when (/= clicked-row -1)
89      (setq row clicked-row))
90    (inspect (aref (matched-symbols wc) row))))
91
92(objc:defmethod (#/source: :void) ((wc xapropos-window-controller) sender)
93  (declare (ignore sender))
94  (let* ((row (#/selectedRow (table-view wc)))
95         (clicked-row (#/clickedRow (table-view wc))))
96    (when (/= clicked-row -1)
97      (setq row clicked-row))
98    (hemlock::edit-definition (aref (matched-symbols wc) row))))
99
100(objc:defmethod (#/validateMenuItem: #>BOOL) ((wc xapropos-window-controller) menu-item)
101  (cond ((or (eql (action-menu wc) (#/menu menu-item))
102             (eql (contextual-menu wc) (#/menu menu-item)))
103         (let ((row (#/selectedRow (table-view wc)))
104               (clicked-row (#/clickedRow (table-view wc)))
105               (tag (#/tag menu-item)))
106           (when (/= clicked-row -1)
107             (setq row clicked-row))
108           (when (/= row -1)
109             (cond ((= tag $inspect-item-tag) t)
110                   ((= tag $source-item-tag)
111                    (let ((sym (aref (matched-symbols wc) row)))
112                      (edit-definition-p sym)))
113                   (t nil)))))
114        (t t)))
115
116(objc:defmethod (#/numberOfRowsInTableView: #>NSInteger) ((wc xapropos-window-controller)
117                                                          table-view)
118  (declare (ignore table-view))
119  (length (matched-symbols wc)))
120
121(objc:defmethod #/tableView:objectValueForTableColumn:row: ((wc xapropos-window-controller)
122                                                            table-view table-column
123                                                            (row #>NSInteger))
124  (declare (ignore table-view table-column))
125  (with-accessors ((array row-objects)
126                   (syms matched-symbols)) wc
127    (when (eql (#/objectAtIndex: array row) (#/null ns:ns-null))
128      (let ((name (%make-nsstring (prin1-to-string (aref syms row)))))
129        (#/replaceObjectAtIndex:withObject: array row name)
130        (#/release name)))
131    (#/objectAtIndex: array row)))
Note: See TracBrowser for help on using the repository browser.