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

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

Add Load File... and Compile File... menu items, handled by
#/loadFile: and #/compileFile:. These are simple-minded, and
could be a lot cleverer.

File size: 6.8 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(objc:defmethod (#/showSearchFiles: :void) ((self lisp-application-delegate)
82                                            sender)
83  ;;If command key is pressed, always make a new window
84  ;;otherwise bring frontmost search files window to the front
85  (declare (ignore sender))
86  (let ((w nil))
87    (if (or (current-event-command-key-p)
88            (null (setf w (first-window-with-controller-type 'search-files-window-controller))))
89      (let* ((wc (make-instance 'search-files-window-controller)))
90        (setf w (#/window wc))
91        (#/setWindowController: w wc))
92      (#/makeKeyAndOrderFront: w self))))
93
94(objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
95                                        sender)
96  (declare (ignore sender))
97  (#/openUntitledDocumentOfType:display:
98   (#/sharedDocumentController ns:ns-document-controller) #@"Listener" t))
99
100(objc:defmethod (#/showListener: :void) ((self lisp-application-delegate)
101                                        sender)
102  (declare (ignore sender))
103  (let* ((all-windows (#/orderedWindows *NSApp*))
104         (key-window (#/keyWindow *NSApp*))
105         (listener-windows ())
106         (top-listener nil))
107    (dotimes (i (#/count all-windows))
108      (let* ((w (#/objectAtIndex: all-windows i))
109             (wc (#/windowController w)))
110        (when (eql (#/class wc) hemlock-listener-window-controller)
111          (push w listener-windows))))
112    (setq listener-windows (nreverse listener-windows))
113    (setq top-listener (car listener-windows))
114    (cond 
115     ((null listener-windows)
116      (#/newListener: self +null-ptr+))
117     ((eql key-window top-listener)
118      ;; The current window is a listener.  If there is more than
119      ;; one listener, bring the rear-most forward.
120      (let* ((w (car (last listener-windows))))
121        (if (eql top-listener w)
122          (#_NSBeep)
123          (#/makeKeyAndOrderFront: w +null-ptr+))))
124     (t
125      (#/makeKeyAndOrderFront: top-listener +null-ptr+)))))
126
127(objc:defmethod (#/ensureListener: :void) ((self lisp-application-delegate)
128                                           sender)
129  (declare (ignore sender))
130  (let ((top-listener-document (#/topListener hemlock-listener-document)))
131    (when (eql top-listener-document +null-ptr+)
132      (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
133             (wc nil))
134        (setq top-listener-document
135              (#/makeUntitledDocumentOfType:error: dc #@"Listener" +null-ptr+))
136        (#/addDocument: dc top-listener-document)
137        (#/makeWindowControllers top-listener-document)
138        (setq wc (#/lastObject (#/windowControllers top-listener-document)))
139        (#/orderFront: (#/window wc) +null-ptr+)))))
140
141(defvar *cocoa-application-finished-launching* (make-semaphore)
142  "Semaphore that's signaled when the application's finished launching ...")
143
144(objc:defmethod (#/applicationDidFinishLaunching: :void)
145    ((self lisp-application-delegate) notification)
146  (declare (ignore notification))
147  (signal-semaphore *cocoa-application-finished-launching*))
148
149(objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
150    ((self lisp-application-delegate) app)
151  (when (zerop *cocoa-listener-count*)
152    (#/newListener: self app)
153    t))
154
155(objc:defmethod (#/loadFile: :void) ((self lisp-application-delegate) sender)
156  (declare (ignore sender))
157  (let ((filename (cocoa-choose-file-dialog
158                   :button-string "Load"
159                   :file-types (list (pathname-type *.lisp-pathname*)
160                                     (pathname-type *.fasl-pathname*)))))
161    (when filename
162      (#/ensureListener: self nil)
163      (let* ((doc (#/topListener hemlock-listener-document))
164             (process (hemlock-document-process doc)))
165        (process-interrupt process #'(lambda ()
166                                       (load filename)
167                                       (fresh-line)))))))
168
169(objc:defmethod (#/compileFile: :void) ((self lisp-application-delegate) sender)
170  (declare (ignore sender))
171  (let ((filename (cocoa-choose-file-dialog
172                   :button-string "Compile"
173                   :file-types (list (pathname-type *.lisp-pathname*)))))
174    (when filename
175      (#/ensureListener: self nil)
176      (let* ((doc (#/topListener hemlock-listener-document))
177             (process (hemlock-document-process doc)))
178        (process-interrupt process #'(lambda ()
179                                       (compile-file filename)
180                                       (fresh-line)))))))
181
Note: See TracBrowser for help on using the repository browser.