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

Last change on this file since 12563 was 12563, checked in by gz, 10 years ago

compiler warning

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