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

Last change on this file since 11991 was 11991, checked in by rme, 11 years ago

Add an Experiments menu. The idea is that this menu will include,
er, experimental stuff.

The first experiment: a redesigned and simplified apropos dialog.

At the moment, this code won't work on Tiger. Tiger users will
get an error if they to pick anything from the Experiments menu.
(The IDE should still load, though, thanks to a kludge in the
BUILD-IDE function.)

File size: 7.1 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(objc:defmethod (#/applicationWillFinishLaunching: :void)
38    ((self lisp-application-delegate) notification)
39  (declare (ignore notification))
40  (initialize-user-interface)
41  (let* ((c (#/init (#/alloc console-window))))
42    (unless (%null-ptr-p c)
43      (setf (console *nsapp*) c))))
44
45(objc:defmethod (#/applicationWillTerminate: :void)
46                ((self lisp-application-delegate) notification)
47  (declare (ignore notification))
48  ;; UI has decided to quit; terminate other lisp threads.
49  (ccl::prepare-to-quit))
50
51(defloadvar *preferences-window-controller* nil)
52
53(objc:defmethod (#/showPreferences: :void) ((self lisp-application-delegate)
54                                            sender)
55  (declare (ignore sender))
56  (when (null *preferences-window-controller*)
57    (setf *preferences-window-controller*
58          (make-instance 'preferences-window-controller)))
59  (#/showWindow: *preferences-window-controller* self))
60
61(defloadvar *processes-window-controller* nil)
62
63(objc:defmethod (#/showProcessesWindow: :void) ((self lisp-application-delegate)
64                                                sender)
65  (declare (ignore sender))
66  (when (null *processes-window-controller*)
67    (setf *processes-window-controller*
68          (make-instance 'processes-window-controller)))
69  (#/showWindow: *processes-window-controller* self))
70
71(defloadvar *apropos-window-controller* nil)
72
73(objc:defmethod (#/showAproposWindow: :void) ((self lisp-application-delegate)
74                                                sender)
75  (declare (ignore sender))
76  (when (null *apropos-window-controller*)
77    (setf *apropos-window-controller*
78          (make-instance 'apropos-window-controller)))
79  (#/showWindow: *apropos-window-controller* self))
80
81(defvar *xapropos-window-controller* nil)
82
83(objc:defmethod (#/showXaproposWindow: :void) ((self lisp-application-delegate)
84                                                sender)
85  (declare (ignore sender))
86  (when (null *xapropos-window-controller*)
87    (setf *apropos-window-controller*
88          (make-instance 'xapropos-window-controller)))
89  (#/showWindow: *apropos-window-controller* self))
90
91(objc:defmethod (#/showSearchFiles: :void) ((self lisp-application-delegate)
92                                            sender)
93  ;;If command key is pressed, always make a new window
94  ;;otherwise bring frontmost search files window to the front
95  (declare (ignore sender))
96  (let ((w nil))
97    (if (or (current-event-command-key-p)
98            (null (setf w (first-window-with-controller-type 'search-files-window-controller))))
99      (let* ((wc (make-instance 'search-files-window-controller)))
100        (setf w (#/window wc)))
101      (#/makeKeyAndOrderFront: w self))))
102
103(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
104                                        sender)
105  (declare (ignore sender))
106  (#/openUntitledDocumentOfType:display:
107   (#/sharedDocumentController ns:ns-document-controller) #@"Listener" t))
108
109(objc:defmethod (#/showListener: :void) ((self lisp-application-delegate)
110                                        sender)
111  (declare (ignore sender))
112  (let* ((all-windows (#/orderedWindows *NSApp*))
113         (key-window (#/keyWindow *NSApp*))
114         (listener-windows ())
115         (top-listener nil))
116    (dotimes (i (#/count all-windows))
117      (let* ((w (#/objectAtIndex: all-windows i))
118             (wc (#/windowController w)))
119        (when (eql (#/class wc) hemlock-listener-window-controller)
120          (push w listener-windows))))
121    (setq listener-windows (nreverse listener-windows))
122    (setq top-listener (car listener-windows))
123    (cond 
124     ((null listener-windows)
125      (#/newListener: self +null-ptr+))
126     ((eql key-window top-listener)
127      ;; The current window is a listener.  If there is more than
128      ;; one listener, bring the rear-most forward.
129      (let* ((w (car (last listener-windows))))
130        (if (eql top-listener w)
131          (#_NSBeep)
132          (#/makeKeyAndOrderFront: w +null-ptr+))))
133     (t
134      (#/makeKeyAndOrderFront: top-listener +null-ptr+)))))
135
136(objc:defmethod (#/ensureListener: :void) ((self lisp-application-delegate)
137                                           sender)
138  (declare (ignore sender))
139  (let ((top-listener-document (#/topListener hemlock-listener-document)))
140    (when (eql top-listener-document +null-ptr+)
141      (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
142             (wc nil))
143        (setq top-listener-document
144              (#/makeUntitledDocumentOfType:error: dc #@"Listener" +null-ptr+))
145        (#/addDocument: dc top-listener-document)
146        (#/makeWindowControllers top-listener-document)
147        (setq wc (#/lastObject (#/windowControllers top-listener-document)))
148        (#/orderFront: (#/window wc) +null-ptr+)))))
149
150(defvar *cocoa-application-finished-launching* (make-semaphore)
151  "Semaphore that's signaled when the application's finished launching ...")
152
153(objc:defmethod (#/applicationDidFinishLaunching: :void)
154    ((self lisp-application-delegate) notification)
155  (declare (ignore notification))
156  (signal-semaphore *cocoa-application-finished-launching*))
157
158(objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
159    ((self lisp-application-delegate) app)
160  (when (zerop *cocoa-listener-count*)
161    (#/newListener: self app)
162    t))
163
164(objc:defmethod (#/loadFile: :void) ((self lisp-application-delegate) sender)
165  (declare (ignore sender))
166  (let ((filename (cocoa-choose-file-dialog
167                   :button-string "Load"
168                   :file-types (list (pathname-type *.lisp-pathname*)
169                                     (pathname-type *.fasl-pathname*)))))
170    (when filename
171      (#/ensureListener: self nil)
172      (let* ((doc (#/topListener hemlock-listener-document))
173             (process (hemlock-document-process doc)))
174        (process-interrupt process #'(lambda ()
175                                       (load filename)
176                                       (fresh-line)))))))
177
178(objc:defmethod (#/compileFile: :void) ((self lisp-application-delegate) sender)
179  (declare (ignore sender))
180  (let ((filename (cocoa-choose-file-dialog
181                   :button-string "Compile"
182                   :file-types (list (pathname-type *.lisp-pathname*)))))
183    (when filename
184      (#/ensureListener: self nil)
185      (let* ((doc (#/topListener hemlock-listener-document))
186             (process (hemlock-document-process doc)))
187        (process-interrupt process #'(lambda ()
188                                       (compile-file filename)
189                                       (fresh-line)))))))
190
Note: See TracBrowser for help on using the repository browser.