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

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

Checkpoint work-in-progress.

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    (let ((n (#/null ns:ns-null)))
65      (dotimes (i (length v))
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.