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 | (objc:defmethod (#/showListener: :void) ((self lisp-application-delegate) |
---|
138 | sender) |
---|
139 | (declare (ignore sender)) |
---|
140 | (let* ((all-windows (#/orderedWindows *NSApp*)) |
---|
141 | (key-window (#/keyWindow *NSApp*)) |
---|
142 | (listener-windows ()) |
---|
143 | (top-listener nil)) |
---|
144 | (dotimes (i (#/count all-windows)) |
---|
145 | (let* ((w (#/objectAtIndex: all-windows i)) |
---|
146 | (wc (#/windowController w))) |
---|
147 | (when (eql (#/class wc) hemlock-listener-window-controller) |
---|
148 | (push w listener-windows)))) |
---|
149 | (setq listener-windows (nreverse listener-windows)) |
---|
150 | (setq top-listener (car listener-windows)) |
---|
151 | (cond |
---|
152 | ((null listener-windows) |
---|
153 | (#/newListener: self +null-ptr+)) |
---|
154 | ((eql key-window top-listener) |
---|
155 | ;; The current window is a listener. If there is more than |
---|
156 | ;; one listener, bring the rear-most forward. |
---|
157 | (let* ((w (car (last listener-windows)))) |
---|
158 | (if (eql top-listener w) |
---|
159 | (#_NSBeep) |
---|
160 | (#/makeKeyAndOrderFront: w +null-ptr+)))) |
---|
161 | (t |
---|
162 | (#/makeKeyAndOrderFront: top-listener +null-ptr+))))) |
---|
163 | |
---|
164 | (objc:defmethod (#/ensureListener: :void) ((self lisp-application-delegate) |
---|
165 | sender) |
---|
166 | (declare (ignore sender)) |
---|
167 | (let ((top-listener-document (#/topListener hemlock-listener-document))) |
---|
168 | (when (eql top-listener-document +null-ptr+) |
---|
169 | (let* ((dc (#/sharedDocumentController ns:ns-document-controller)) |
---|
170 | (wc nil)) |
---|
171 | (setq top-listener-document |
---|
172 | #+cocotron (#/makeUntitledDocumentOfType: dc #@"Listener") |
---|
173 | #-cocotron (#/makeUntitledDocumentOfType:error: dc #@"Listener" +null-ptr+)) |
---|
174 | (#/addDocument: dc top-listener-document) |
---|
175 | (#/makeWindowControllers top-listener-document) |
---|
176 | (setq wc (#/lastObject (#/windowControllers top-listener-document))) |
---|
177 | (#/orderFront: (#/window wc) +null-ptr+))))) |
---|
178 | |
---|
179 | (defvar *cocoa-application-finished-launching* (make-semaphore) |
---|
180 | "Semaphore that's signaled when the application's finished launching ...") |
---|
181 | |
---|
182 | (objc:defmethod (#/applicationDidFinishLaunching: :void) |
---|
183 | ((self lisp-application-delegate) notification) |
---|
184 | (declare (ignore notification)) |
---|
185 | (signal-semaphore *cocoa-application-finished-launching*)) |
---|
186 | |
---|
187 | (objc:defmethod (#/applicationShouldOpenUntitledFile: #>BOOL) |
---|
188 | ((self lisp-application-delegate) app) |
---|
189 | (declare (ignore app)) |
---|
190 | t) |
---|
191 | |
---|
192 | (objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>) |
---|
193 | ((self lisp-application-delegate) app) |
---|
194 | (when (zerop *cocoa-listener-count*) |
---|
195 | (#/newListener: self app) |
---|
196 | t)) |
---|
197 | |
---|
198 | (objc:defmethod (#/loadFile: :void) ((self lisp-application-delegate) sender) |
---|
199 | (declare (ignore sender)) |
---|
200 | (let ((filename (cocoa-choose-file-dialog |
---|
201 | :button-string "Load" |
---|
202 | :file-types (list (pathname-type *.lisp-pathname*) |
---|
203 | (pathname-type *.fasl-pathname*))))) |
---|
204 | (when filename |
---|
205 | (#/ensureListener: self nil) |
---|
206 | (let* ((doc (#/topListener hemlock-listener-document)) |
---|
207 | (process (hemlock-document-process doc))) |
---|
208 | (process-interrupt process #'(lambda () |
---|
209 | (load filename) |
---|
210 | (fresh-line))))))) |
---|
211 | |
---|
212 | (objc:defmethod (#/compileFile: :void) ((self lisp-application-delegate) sender) |
---|
213 | (declare (ignore sender)) |
---|
214 | (let ((filename (cocoa-choose-file-dialog |
---|
215 | :button-string "Compile" |
---|
216 | :file-types (list (pathname-type *.lisp-pathname*))))) |
---|
217 | (when filename |
---|
218 | (#/ensureListener: self nil) |
---|
219 | (let* ((doc (#/topListener hemlock-listener-document)) |
---|
220 | (process (hemlock-document-process doc))) |
---|
221 | (process-interrupt process #'(lambda () |
---|
222 | (compile-file filename) |
---|
223 | (fresh-line))))))) |
---|
224 | |
---|
225 | (objc:defmethod (#/exitBreak: :void) ((self lisp-application-delegate) sender) |
---|
226 | (let* ((top-listener (#/topListener hemlock-listener-document))) |
---|
227 | (unless (%null-ptr-p top-listener) |
---|
228 | (#/exitBreak: top-listener sender)))) |
---|
229 | |
---|
230 | (objc:defmethod (#/continue: :void) ((self lisp-application-delegate) sender) |
---|
231 | (let* ((top-listener (#/topListener hemlock-listener-document))) |
---|
232 | (unless (%null-ptr-p top-listener) |
---|
233 | (#/continue: top-listener sender)))) |
---|
234 | |
---|
235 | (objc:defmethod (#/restarts: :void) ((self lisp-application-delegate) sender) |
---|
236 | (let* ((top-listener (#/topListener hemlock-listener-document))) |
---|
237 | (unless (%null-ptr-p top-listener) |
---|
238 | (#/restarts: top-listener sender)))) |
---|
239 | |
---|
240 | (objc:defmethod (#/backtrace: :void) ((self lisp-application-delegate) sender) |
---|
241 | (let* ((top-listener (#/topListener hemlock-listener-document))) |
---|
242 | (unless (%null-ptr-p top-listener) |
---|
243 | (#/backtrace: top-listener sender)))) |
---|
244 | |
---|
245 | (objc:defmethod (#/validateMenuItem: #>BOOL) ((self lisp-application-delegate) item) |
---|
246 | (let* ((action (#/action item))) |
---|
247 | (cond ((or (eql action (@selector "exitBreak:")) |
---|
248 | (eql action (@selector "continue:")) |
---|
249 | (eql action (@selector "restarts:")) |
---|
250 | (eql action (@selector "backtrace:"))) |
---|
251 | (let* ((top-listener (#/topListener hemlock-listener-document))) |
---|
252 | (unless (%null-ptr-p top-listener) |
---|
253 | (#/validateMenuItem: top-listener item)))) |
---|
254 | (t t)))) |
---|
255 | |
---|
256 | |
---|