source: release/1.4/source/cocoa-ide/project.lisp @ 13049

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

Merge trunk changes r13033 through 13035, r13048.

File size: 18.3 KB
Line 
1(in-package "GUI")
2
3;;; This file contains a project browser for the CCL IDE. A "project" is
4;;; just the set of ASDF systems defined in the same file.
5;;;
6;;; To browse a project, run (gui::make-project-window :project-name). The
7;;; project name is the name of the .asd file. However, if the .asd has been
8;;; loaded, then the project browser can be opened using the name of any of the
9;;; systems defined in that file.
10;;;
11;;; Todo:
12;;; • support modification without resorting to editor window
13;;; • raise window if project already open
14;;; • handle #-ccl sections in .asd
15;;; • support arbitrary operations
16
17(eval-when (:compile-toplevel :load-toplevel :execute)
18  (require :asdf))
19
20(defclass project-window-controller (ns:ns-window-controller)
21  ((system-view :foreign-type :id :accessor system-view) ; IBOutlet
22   (component-view :foreign-type :id :accessor component-view) ; IBOutlet
23
24   ;; Info Panel fields
25   (info-panel :foreign-type :id :accessor info-panel) ; IBOutlet
26   (name-label :foreign-type :id)
27   (version-label :foreign-type :id)
28   (author-label :foreign-type :id)
29   (maintainer-label :foreign-type :id)
30   (licence-label :foreign-type :id)
31   (description-label :foreign-type :id)
32   (long-description-label :foreign-type :id)
33
34   (system-menu :foreign-type :id :accessor system-menu) ; IBOutlet set by NIB
35   (item-menu :foreign-type :id :accessor item-menu) ; IBOutlet set by NIB
36   (op-button :foreign-type :id :accessor op-button) ; IBOutlet set by NIB
37   (toolbar-items :foreign-type :id :accessor toolbar-items)
38   (project-item :initarg :project-item :reader project-item)
39   (components-field :reader components-field
40                     :initform (make-instance 'ns:ns-text-field-cell
41                                 :text-cell #@"Components"))
42   (dependencies-field :reader dependencies-field
43                       :initform (make-instance 'ns:ns-text-field-cell
44                                   :text-cell #@"Dependencies")))
45  (:metaclass ns:+ns-object))
46
47(defmethod current-system-item (controller)
48  (#/objectAtIndex: (systems (project-item controller))
49                    (#/selectedRow (system-view controller))))
50
51;;; Need to represent system in a way that the NSOutlineView likes
52
53(defclass component-item (ns:ns-object)
54  ((name :foreign-type :id :accessor name))
55  (:metaclass ns:+ns-object))
56
57(defclass module-item (component-item)
58  ((components :foreign-type :id :accessor components
59               :initform (make-instance 'ns:ns-mutable-array)))
60  (:metaclass ns:+ns-object))
61
62(defclass project-item (ns:ns-object)
63  ((name :foreign-type :id :accessor name)
64   (systems :foreign-type :id :accessor systems
65            :initform (make-instance 'ns:ns-mutable-array)))
66  (:metaclass ns:+ns-object))
67
68(defclass system-item (module-item)
69  ((system :accessor system))
70  (:metaclass ns:+ns-object))
71
72(defclass dependency-item (ns:ns-object)
73  ((name :foreign-type :id :accessor name)
74   (operations :foreign-type :id :accessor operations
75               :initform (make-instance 'ns:ns-mutable-array)))
76  (:metaclass ns:+ns-object))
77
78(defclass file-item (component-item)
79  ((location :foreign-type :id :accessor location))
80  (:metaclass ns:+ns-object))
81
82(defmethod (setf component) (component (object component-item))
83  (setf (name object) (%make-nsstring (asdf:component-name component))))
84
85(defmethod (setf component) (component (object module-item))
86  (call-next-method)
87  (setf (components object) (make-instance 'ns:ns-mutable-array))
88  (mapc (lambda (com)
89          (#/addObject: (components object)
90                        (let ((obj (make-instance
91                                       (typecase com
92                                         (asdf:system 'system-item)
93                                         (asdf:module 'module-item)
94                                         (asdf:source-file 'file-item)))))
95                          (setf (component obj) com)
96                          obj)))
97        (asdf:module-components component)))
98
99(defmethod (setf component) (component (object system-item))
100  (call-next-method)
101  (setf (system object) component))
102
103(defmethod (setf component) (component (object file-item))
104  (call-next-method)
105  (setf (location object)
106        (%make-nsstring (namestring (asdf:component-pathname component)))))
107
108(objc:defmethod #/init ((self project-window-controller))
109  (#/setShouldCascadeWindows: self t)
110  (#/initWithWindowNibName: self #@"project"))
111
112(objc:defmethod (#/awakeFromNib :void) ((self project-window-controller))
113  (with-slots (system-view component-view
114               system-menu item-menu
115               op-button toolbar-items)
116              self
117    (let ((toolbar (make-instance 'ns:ns-toolbar
118                     :with-identifier #@"projectbar")))
119      (setf (#/allowsUserCustomization toolbar) t
120            (#/delegate toolbar) self)
121      (setf toolbar-items (make-instance 'ns:ns-mutable-dictionary))
122      (let ((op-item (make-instance 'ns:ns-toolbar-item
123                       :with-item-identifier #@"operate")))
124        (setf (#/label op-item) #@"Operate"
125              (#/paletteLabel op-item) #@"Operate")
126        (let* ((op-menu (#/menu op-button)))
127          (loop for i from 1 to (1- (#/numberOfItems op-menu)) ; 0 is blank
128            do (let ((item (#/itemAtIndex: op-menu i)))
129                 (#/setTarget: item self)
130                 (#/setAction: item (@selector #/operate:)))))
131        (setf (#/view op-item) op-button
132              (#/objectForKey: toolbar-items #@"operate") op-item))
133      (let ((toolbar-item (make-instance 'ns:ns-toolbar-item
134                            :with-item-identifier #@"info")))
135        (setf (#/label toolbar-item) #@"Get Info"
136              (#/paletteLabel toolbar-item) #@"Get Info"
137              #-cocotron (#/image toolbar-item) #-cocotron (#/imageNamed: ns:ns-image
138                                                                          #&NSImageNameInfo)
139              (#/target toolbar-item) self
140              (#/action toolbar-item) (@selector #/showInfoPanel)
141              (#/objectForKey: toolbar-items #@"info") toolbar-item))
142      (let ((toolbar-item (make-instance 'ns:ns-toolbar-item
143                            :with-item-identifier #@"edit")))
144        (setf (#/label toolbar-item) #@"Edit"
145              (#/paletteLabel toolbar-item) #@"Edit"
146              #-cocotron (#/image toolbar-item) #-cocotron (#/imageNamed: ns:ns-image
147                                                                          #&NSImageNameFontPanel)
148              (#/target toolbar-item) self
149              (#/action toolbar-item) (@selector #/openSystem:)
150              (#/objectForKey: toolbar-items #@"edit") toolbar-item))
151      (#/setToolbar: (#/window self) toolbar))
152    (let ((mi0 (#/itemAtIndex: system-menu 0)) ; Operate
153          (mi1 (#/itemAtIndex: system-menu 1)) ; Get Info
154          (mi2 (#/itemAtIndex: system-menu 2))) ; Edit
155      (let* ((op-menu (#/menu mi0)))
156        (loop for i from 0 to (1- (#/numberOfItems op-menu))
157          do (let ((item (#/itemAtIndex: op-menu i)))
158               (setf (#/enabled item) t
159                     (#/target item) self
160                     (#/action item) (@selector #/operate:)))))
161      (setf (#/enabled mi1) t
162            (#/target mi1) self
163            (#/action mi1) (@selector #/showInfoPanel))
164      (setf (#/enabled mi2) t
165            (#/target mi2) self
166            (#/action mi2) (@selector #/openSystem:)))
167    (setf (#/target system-view) self
168          (#/doubleAction system-view) (@selector #/openSystem:))
169    (let ((mi0 (#/itemAtIndex: item-menu 0)) ; Open
170          (mi1 (#/itemAtIndex: item-menu 1)) ; Compile
171          (mi2 (#/itemAtIndex: item-menu 2))) ; Compile and Load
172      (setf (#/enabled mi0) t
173            (#/target mi0) self
174            (#/action mi0) (@selector #/openComponent:))
175      (setf (#/enabled mi1) t
176            (#/target mi1) self
177            (#/action mi1) (@selector #/compileComponent:))
178      (setf (#/enabled mi2) t
179            (#/target mi2) self
180            (#/action mi2) (@selector #/compileAndLoadComponent:)))
181    (setf (#/target component-view) self
182          (#/doubleAction component-view) (@selector #/openComponent:))))
183
184(objc:defmethod (#/showInfoPanel :void) ((self project-window-controller))
185  (with-slots (info-panel name-label version-label author-label maintainer-label
186               licence-label description-label long-description-label)
187    self
188    (let ((system (system (current-system-item self))))
189      (#/makeKeyAndOrderFront: info-panel self)
190      (setf (#/stringValue name-label)
191            (%make-nsstring (asdf:component-name system))
192            (#/stringValue version-label)
193            (%make-nsstring (handler-case (asdf:component-version system)
194                              (slot-unbound () "")))
195            (#/stringValue author-label)
196            (%make-nsstring (handler-case (asdf:system-author system)
197                              (slot-unbound () "")))
198            (#/stringValue maintainer-label)
199            (%make-nsstring (handler-case (asdf:system-maintainer system)
200                              (slot-unbound () "")))
201            (#/stringValue licence-label)
202            (%make-nsstring (handler-case (asdf:system-licence system)
203                              (slot-unbound () "")))
204            (#/stringValue description-label)
205            (%make-nsstring (handler-case (asdf:system-description system)
206                              (slot-unbound () "")))
207            (#/stringValue long-description-label)
208            (%make-nsstring (handler-case
209                                (asdf:system-long-description system)
210                              (slot-unbound () "")))))))
211
212;;; NSToolbar delegate methods
213
214(objc:defmethod #/toolbar:itemForItemIdentifier:willBeInsertedIntoToolbar:
215                ((self project-window-controller)
216                 toolbar itemIdentifier (flag :<BOOL>))
217  (declare (ignore toolbar))
218  (#/objectForKey: (toolbar-items self) itemIdentifier))
219
220(objc:defmethod #/toolbarAllowedItemIdentifiers:
221                ((self project-window-controller) toolbar)
222  (declare (ignore toolbar))
223  (#/allKeys (toolbar-items self)))
224
225(objc:defmethod #/toolbarDefaultItemIdentifiers:
226                ((self project-window-controller) toolbar)
227  (declare (ignore toolbar))
228  (#/arrayWithObjects: ns:ns-array #@"operate" #@"info" #@"edit" +null-ptr+))
229
230(objc:defmethod (#/openSystem: :void) ((self project-window-controller) sender)
231  (declare (ignore sender))
232  (find-or-make-hemlock-view
233   (asdf:system-source-file (lisp-string-from-nsstring
234                             (name (project-item self))))))
235
236(objc:defmethod (#/openComponent: :void)
237                ((self project-window-controller) sender)
238  (declare (ignore sender))
239  (let ((row (#/clickedRow (component-view self))))
240    (unless (minusp row)
241      (let ((item (#/itemAtRow: (component-view self) row)))
242        (typecase item 
243          (file-item (find-or-make-hemlock-view
244                      (lisp-string-from-nsstring (location item))))
245          (ns:ns-string (make-project-window
246                         (make-symbol (string-upcase (lisp-string-from-nsstring
247                                                      item))))))))))
248
249(objc:defmethod (#/compileComponent: :void)
250                ((self project-window-controller) sender)
251  (declare (ignore sender))
252  (let ((row (#/clickedRow (component-view self))))
253    (unless (minusp row)
254      (let ((item (#/itemAtRow: (component-view self) row)))
255        (when (typep item 'file-item)
256          (ui-object-compile-buffer *NSApp*
257                                    (list :cl-user
258                                          (lisp-string-from-nsstring
259                                           (location item)))))))))
260
261(objc:defmethod (#/compileAndLoadComponent: :void)
262                ((self project-window-controller) sender)
263  (declare (ignore sender))
264  (let ((row (#/clickedRow (component-view self))))
265    (unless (minusp row)
266      (let ((item (#/itemAtRow: (component-view self) row)))
267        (when (typep item 'file-item)
268          (ui-object-compile-and-load-buffer
269           *NSApp*
270           (list :cl-user (lisp-string-from-nsstring (location item)))))))))
271
272(objc:defmethod (#/operate: :void) ((self project-window-controller) sender)
273  (let* ((target-listener (ui-object-choose-listener-for-selection *NSApp*
274                                                                   nil)))
275    (when target-listener
276      (let ((string (format nil "(asdf:oos 'asdf:~A-op :~A)"
277                            (substitute #\-
278                                        #\space
279                                        (lisp-string-from-nsstring
280                                         (#/title sender)))
281                            (if (= (#/compare: (#/title (#/menu sender))
282                                               #@"project-operations")
283                                   #$NSOrderedSame)
284                              (lisp-string-from-nsstring
285                               (name (project-item self)))
286                              (asdf:component-name
287                               (system (current-system-item self)))))))
288        (eval-in-listener-process target-listener string)))))
289
290(defmethod (setf project-item)
291           ((value asdf:system) (self project-window-controller))
292  (let ((proj (make-instance 'project-item))
293        (proj-name (pathname-name (asdf:system-source-file value))))
294    (setf (name proj) (%make-nsstring proj-name))
295    (setf (systems proj) (make-instance 'ns:ns-mutable-array))
296    (mapc (lambda (system)
297            (let ((component (make-instance 'system-item)))
298              (setf (component component) system)
299              (#/addObject: (systems proj) component)))
300          (find-related-systems value))
301    (setf (slot-value self 'project-item) proj)
302    (#/setTitle: (#/window self)
303                 (%make-nsstring (concatenate 'string
304                                              proj-name " – Project"))))
305  (#/reloadData (component-view self)))
306
307;;; NSTableView data source methods
308
309(objc:defmethod (#/tableView:objectValueForTableColumn:row: :id)
310                ((self project-window-controller)
311                 table-view column (row :<NSI>nteger))
312  (declare (ignore table-view column))
313  (name (#/objectAtIndex: (systems (project-item self)) row)))
314
315(objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger)
316                ((self project-window-controller) table-view)
317  (declare (ignore table-view))
318  (#/count (systems (project-item self))))
319
320(objc:defmethod (#/tableViewSelectionDidChange: :void)
321                ((self project-window-controller) sender)
322  (declare (ignore sender))
323  (#/reloadData (component-view self)))
324
325;;; NSOutlineView data source methods
326
327(objc:defmethod (#/outlineView:child:ofItem: :id)
328                ((self project-window-controller)
329                 outline-view (index :<NSI>nteger) item)
330  (declare (ignore outline-view))
331  (cond ((eql item +null-ptr+) (case index
332                                 (0 (components-field self))
333                                 (1 (dependencies-field self))))
334        ((typep item 'component-item)
335         (#/objectAtIndex: (components item) index))
336        ((eql item (components-field self))
337         (#/objectAtIndex: (components (current-system-item self)) index))
338        ((eql item (dependencies-field self))
339         (let ((dependency (nth index
340                                (remove (asdf:component-name
341                                         (system (current-system-item self)))
342                                        (reduce #'union
343                                                (asdf:component-depends-on
344                                                 'asdf:load-op
345                                                 (system (current-system-item
346                                                          self)))
347                                                :key #'cdr)))))
348           (%make-nsstring (if (consp dependency)
349                             (second dependency)
350                             dependency))))))
351
352(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
353                ((self project-window-controller) outline-view item)
354  (declare (ignore outline-view))
355  (not (or (typep item 'file-item) (typep item 'ns:ns-string))))
356
357(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
358                ((self project-window-controller) outline-view item)
359  (declare (ignore outline-view))
360  (cond ((eql item +null-ptr+) 2)
361        ((typep item 'component-item) (#/count (components item)))
362        ((eql item (components-field self))
363         (#/count (components (current-system-item self))))
364        ((eql item (dependencies-field self))
365         (length (remove (asdf:component-name (system (current-system-item
366                                                       self)))
367                         (reduce #'union
368                                 (asdf:component-depends-on
369                                  'asdf:load-op
370                                  (system (current-system-item self)))
371                                 :key #'cdr))))))
372
373(objc:defmethod (#/outlineView:objectValueForTableColumn:byItem: :id)
374                ((self project-window-controller) outline-view column item)
375  (declare (ignore outline-view column))
376  (cond ((eql item +null-ptr+) (name (current-system-item self)))
377        ((typep item 'component-item) (name item))
378        (t item)))
379
380(objc:defmethod (#/outlineView:shouldSelectItem: :<BOOL>)
381                ((self project-window-controller) outline-view item)
382  (declare (ignore outline-view))
383  (not (typep item 'ns:ns-text-field-cell)))
384
385(objc:defmethod (#/outlineView:isGroupItem: :<BOOL>)
386                ((self project-window-controller) outline-view item)
387  (declare (ignore outline-view))
388  (typep item 'ns:ns-text-field-cell))
389
390(defgeneric make-project-window (obj)
391  (:method ((obj asdf:system))
392           (let ((controller (make-instance 'project-window-controller)))
393             (setf (project-item controller) obj)
394             (#/showWindow: controller nil)
395             controller))
396  (:method (obj)
397           (make-project-window (asdf:find-system obj))))
398
399(defun find-related-systems (obj)
400  "This just uses our assumption that a project is the set of systems in a
401   single .asd. It just finds all the systems with the same system-source-file."
402  (let ((system-file (asdf:system-source-file (asdf:find-system obj))))
403    (loop for system being the hash-values of asdf::*defined-systems*
404      if (equal (asdf:system-source-file (cdr system)) system-file)
405      collect (cdr system))))
Note: See TracBrowser for help on using the repository browser.