source: trunk/source/cocoa-ide/app-delegate.lisp @ 15166

Last change on this file since 15166 was 15166, checked in by gz, 8 years ago

top-listener-process convenience function

File size: 9.9 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
6
7(defclass lisp-application-delegate (ns:ns-object)
8    ()
9  (:metaclass ns:+ns-object))
10
11;;; This method is a good place to:
12;;;  * register value transformer names
13;;;  * register default user defaults
14(objc:defmethod (#/initialize :void) ((self +lisp-application-delegate))
15  (#/setValueTransformer:forName: ns:ns-value-transformer
16                                  (make-instance 'font-to-name-transformer)
17                                  #@"FontToName")
18
19  (let* ((domain (#/standardUserDefaults ns:ns-user-defaults))
20         (initial-values (cocoa-defaults-initial-values))
21         (dict (#/mutableCopy initial-values)))
22    (declare (special *standalone-cocoa-ide*))
23    #+cocotron
24    (#/setObject:forKey:
25     dict
26     (#/dictionaryWithObjectsAndKeys:
27      ns:ns-dictionary
28      #@"Control" #@"LeftControl"
29      #@"Alt" #@"LeftAlt"
30      #@"Command" #@"RightControl"
31      #@"Alt" #@"RightAlt"
32      +null-ptr+)
33     #@"NSModifierFlagMapping")
34    (#/registerDefaults: domain dict)
35    (#/release dict)
36    (update-cocoa-defaults)
37    (when *standalone-cocoa-ide*
38      (init-ccl-directory-for-ide))))
39
40(defun init-ccl-directory-for-ide ()
41  (let* ((bundle-path (#/bundlePath (#/mainBundle ns:ns-bundle)))
42         (parent (#/stringByDeletingLastPathComponent bundle-path))
43         (path (ccl::ensure-directory-pathname
44                (lisp-string-from-nsstring parent))))
45    (ccl::replace-base-translation "ccl:" path)))
46
47
48(defvar *ccl-ide-init-file* "home:ccl-ide-init")
49
50;;; Errors that occur while this file is loading will enter a break
51;;; loop, with *DEBUG-IO* connected to the terminal/Emacs, to AltConsole,
52;;; or to /dev/null and syslog.
53(defun load-ide-init-file ()
54  (with-simple-restart (continue "Skip loading IDE init file.")
55    (load *ccl-ide-init-file* :if-does-not-exist nil :verbose nil)))
56
57(objc:defmethod (#/applicationWillFinishLaunching: :void)
58    ((self lisp-application-delegate) notification)
59  (declare (ignore notification))
60  (initialize-user-interface)
61  (unless (shift-key-now-p)
62    (load-ide-init-file)))
63
64(objc:defmethod (#/applicationWillTerminate: :void)
65                ((self lisp-application-delegate) notification)
66  (declare (ignore notification))
67  ;; UI has decided to quit; terminate other lisp threads.
68  (ccl::prepare-to-quit))
69
70(defloadvar *preferences-window-controller* nil)
71
72(objc:defmethod (#/showPreferences: :void) ((self lisp-application-delegate)
73                                            sender)
74  (declare (ignore sender))
75  (when (null *preferences-window-controller*)
76    (setf *preferences-window-controller*
77          (make-instance 'preferences-window-controller)))
78  (#/showWindow: *preferences-window-controller* self))
79
80(defloadvar *processes-window-controller* nil)
81
82(objc:defmethod (#/showProcessesWindow: :void) ((self lisp-application-delegate)
83                                                sender)
84  (declare (ignore sender))
85  (when (null *processes-window-controller*)
86    (setf *processes-window-controller*
87          (make-instance 'processes-window-controller)))
88  (#/showWindow: *processes-window-controller* self))
89
90(defloadvar *apropos-window-controller* nil)
91
92(objc:defmethod (#/showAproposWindow: :void) ((self lisp-application-delegate)
93                                                sender)
94  (declare (ignore sender))
95  (when (null *apropos-window-controller*)
96    (setf *apropos-window-controller*
97          (make-instance 'apropos-window-controller)))
98  (#/showWindow: *apropos-window-controller* self))
99
100(defloadvar *xapropos-window-controller* nil)
101
102(objc:defmethod (#/showXaproposWindow: :void) ((self lisp-application-delegate)
103                                                sender)
104  (declare (ignore sender))
105  (when (null *xapropos-window-controller*)
106    (setf *xapropos-window-controller*
107          (make-instance 'xapropos-window-controller)))
108  (#/showWindow: *xapropos-window-controller* self))
109
110(objc:defmethod (#/showNewInspector: :void) ((self lisp-application-delegate)
111                                             sender)
112  (declare (ignore sender))
113  (#/showWindow: (make-instance 'inspector::xinspector-window-controller
114                   :inspector (inspector::make-inspector *package*)) self))
115
116(objc:defmethod (#/showSearchFiles: :void) ((self lisp-application-delegate)
117                                            sender)
118  ;;If command key is pressed, always make a new window
119  ;;otherwise bring frontmost search files window to the front
120  (declare (ignore sender))
121  (let ((w nil))
122    (if (or (current-event-modifier-p #$NSFunctionKeyMask)
123            (null (setf w (first-window-with-controller-type 'search-files-window-controller))))
124      (let* ((wc (make-instance 'search-files-window-controller)))
125        (#/showWindow: wc self)
126        (set-search-files-default-dir wc))
127      (progn
128        (#/makeKeyAndOrderFront: w self)
129        (set-search-files-default-dir (#/windowController w))))))
130
131(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
132                                        sender)
133  (declare (ignore sender))
134  (#/openUntitledDocumentOfType:display:
135   (#/sharedDocumentController ns:ns-document-controller) #@"Listener" t))
136
137(defun active-listener-windows ()
138  (let* ((listener-windows ())
139         (all-windows (#/orderedWindows *NSApp*)))
140    (dotimes (i (#/count all-windows) (nreverse listener-windows))
141      (let* ((w (#/objectAtIndex: all-windows i))
142             (wc (#/windowController w)))
143        (when (and (typep wc 'hemlock-listener-window-controller)
144                   (#/isVisible w))
145          (let* ((doc (#/document wc)))
146            (unless (%null-ptr-p doc)
147              (when (hemlock-document-process doc)
148                (push w listener-windows)))))))))
149       
150               
151(objc:defmethod (#/showListener: :void) ((self lisp-application-delegate)
152                                        sender)
153  (declare (ignore sender))
154  (let* ((key-window (#/keyWindow *NSApp*))
155         (listener-windows (active-listener-windows))
156         (top-listener nil))
157    (setq top-listener (car listener-windows))
158    (cond 
159     ((null listener-windows)
160      (#/newListener: self +null-ptr+))
161     ((eql key-window top-listener)
162      ;; The current window is a listener.  If there is more than
163      ;; one listener, bring the rear-most forward.
164      (let* ((w (car (last listener-windows))))
165        (if (eql top-listener w)
166          (#_NSBeep)
167          (#/makeKeyAndOrderFront: w +null-ptr+))))
168     (t
169      (#/makeKeyAndOrderFront: top-listener +null-ptr+)))))
170
171(objc:defmethod (#/ensureListener: :void) ((self lisp-application-delegate)
172                                           sender)
173  (declare (ignore sender))
174  (let ((top-listener-document (#/topListener hemlock-listener-document)))
175    (when (eql top-listener-document +null-ptr+)
176      (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
177             (wc nil))
178        (setq top-listener-document
179              #+cocotron (#/makeUntitledDocumentOfType: dc #@"Listener")
180              #-cocotron (#/makeUntitledDocumentOfType:error: dc #@"Listener" +null-ptr+))
181        (#/addDocument: dc top-listener-document)
182        (#/makeWindowControllers top-listener-document)
183        (setq wc (#/lastObject (#/windowControllers top-listener-document)))
184        (#/orderFront: (#/window wc) +null-ptr+)))))
185
186(defvar *cocoa-application-finished-launching* (make-semaphore)
187  "Semaphore that's signaled when the application's finished launching ...")
188
189(objc:defmethod (#/applicationDidFinishLaunching: :void)
190    ((self lisp-application-delegate) notification)
191  (declare (ignore notification))
192  (signal-semaphore *cocoa-application-finished-launching*))
193
194(objc:defmethod (#/applicationShouldOpenUntitledFile: #>BOOL)
195    ((self lisp-application-delegate) app)
196  (declare (ignore app))
197  t)
198
199(objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
200    ((self lisp-application-delegate) app)
201  (when (zerop *cocoa-listener-count*)
202    (#/newListener: self app)
203    t))
204
205(objc:defmethod (#/loadFile: :void) ((self lisp-application-delegate) sender)
206  (declare (ignore sender))
207  (let ((filename (cocoa-choose-file-dialog
208                   :button-string "Load"
209                   :file-types (list (pathname-type *.lisp-pathname*)
210                                     (pathname-type *.fasl-pathname*)))))
211    (when filename
212      (#/ensureListener: self nil)
213      (let ((process (top-listener-process)))
214        (process-interrupt process #'(lambda ()
215                                       (load filename)
216                                       (fresh-line)))))))
217
218(objc:defmethod (#/compileFile: :void) ((self lisp-application-delegate) sender)
219  (declare (ignore sender))
220  (let ((filename (cocoa-choose-file-dialog
221                   :button-string "Compile"
222                   :file-types (list (pathname-type *.lisp-pathname*)))))
223    (when filename
224      (#/ensureListener: self nil)
225      (let ((process (top-listener-process)))
226        (process-interrupt process #'(lambda ()
227                                       (compile-file filename)
228                                       (fresh-line)))))))
229
230(objc:defmethod (#/exitBreak: :void) ((self lisp-application-delegate) sender)
231  (let* ((top-listener (#/topListener hemlock-listener-document)))
232    (unless (%null-ptr-p top-listener)
233      (#/exitBreak: top-listener sender))))
234
235(objc:defmethod (#/continue: :void) ((self lisp-application-delegate) sender)
236  (let* ((top-listener (#/topListener hemlock-listener-document)))
237    (unless (%null-ptr-p top-listener)
238      (#/continue: top-listener sender))))
239
240(objc:defmethod (#/restarts: :void) ((self lisp-application-delegate) sender)
241  (let* ((top-listener (#/topListener hemlock-listener-document)))
242    (unless (%null-ptr-p top-listener)
243      (#/restarts: top-listener sender))))
244
245(objc:defmethod (#/backtrace: :void) ((self lisp-application-delegate) sender)
246  (let* ((top-listener (#/topListener hemlock-listener-document)))
247    (unless (%null-ptr-p top-listener)
248      (#/backtrace: top-listener sender))))
249
250(objc:defmethod (#/validateMenuItem: #>BOOL) ((self lisp-application-delegate) item)
251  (let* ((action (#/action item)))
252    (cond ((or (eql action (@selector "exitBreak:"))
253               (eql action (@selector "continue:"))
254               (eql action (@selector "restarts:"))
255               (eql action (@selector "backtrace:")))
256           (let* ((top-listener (#/topListener hemlock-listener-document)))
257             (unless (%null-ptr-p top-listener)     
258               (#/validateMenuItem: top-listener item))))
259          (t t))))
260
261
Note: See TracBrowser for help on using the repository browser.