source: trunk/source/cocoa-ide/cocoa-window.lisp @ 12179

Last change on this file since 12179 was 12179, checked in by gb, 10 years ago

Fix indentation typo.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.7 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2002-2007 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(in-package "GUI")
19
20(eval-when (:compile-toplevel :load-toplevel :execute)
21  (def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows")
22  (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT")
23  (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters"))
24
25(defun init-cocoa-application ()
26  (with-autorelease-pool
27      (#/standardUserDefaults ns:ns-user-defaults)
28      (let* ((bundle (open-main-bundle))
29             (dict (#/infoDictionary  bundle))
30             (classname (#/objectForKey: dict #@"NSPrincipalClass"))
31             (mainnibname (#/objectForKey: dict  #@"NSMainNibFile"))
32             (progname (#/objectForKey: dict #@"CFBundleName")))
33        (if (%null-ptr-p classname)
34          (error "problems loading bundle: can't determine class name"))
35        (if (%null-ptr-p mainnibname)
36          (error "problems loading bundle: can't determine main nib name"))
37        (unless (%null-ptr-p progname)
38          (#/setProcessName: (#/processInfo ns:ns-process-info) progname))
39        (let* ((appclass (#_NSClassFromString classname))
40               (app (#/sharedApplication appclass)))
41          (#/loadNibNamed:owner: ns:ns-bundle mainnibname  app)
42          app))))
43
44
45
46#+apple-objc
47(defun trace-dps-events (flag)
48  (external-call "__DPSSetEventsTraced"
49                 :unsigned-byte (if flag #$YES #$NO)
50                 :void))
51
52(defclass appkit-process (process)
53    ((have-interactive-terminal-io :initform t)))
54
55;;; Interrupt the AppKit event process, by enqueing an event (if the
56;;; application event loop seems to be running.)  It's possible that
57;;; the event loop will stop after the calling thread checks; in that
58;;; case, the application's probably already in the process of
59;;; exiting, and isn't that different from the case where asynchronous
60;;; interrupts are used.
61(defmethod process-interrupt ((process appkit-process) function &rest args)
62  (if (eq process *current-process*)
63    (apply function args)
64    (if (and *NSApp* (#/isRunning *NSApp*))
65      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
66      #+not-yet
67      (let* ((invoked nil)
68             (f (lambda ()
69                  (unless invoked
70                    (setq invoked t)
71                    (apply function args)))))
72        (queue-for-gui f :at-start t)
73        (call-next-method process f))
74      (call-next-method))))
75
76(defparameter *debug-in-event-process* t)
77
78(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")
79
80(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer)
81  "Better than nothing.  Not much better."
82  (when *debug-in-event-process*
83    (let* ((c (if (typep condition 'ccl::ns-lisp-exception)
84                (ccl::ns-lisp-exception-condition condition)
85                condition)))
86      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
87        (push c *event-process-reported-conditions*)
88        (if (slot-value process 'have-interactive-terminal-io)
89          (ccl::application-error ccl::*application* c frame-pointer)
90          (catch 'need-a-catch-frame-for-backtrace
91            (let* ((*debug-in-event-process* nil)
92                   (context (ccl::new-backtrace-info nil
93                                                     frame-pointer
94                                                     (if ccl::*backtrace-contexts*
95                                                       (or (ccl::child-frame
96                                                            (ccl::bt.youngest (car ccl::*backtrace-contexts*))
97                                                            nil)
98                                                           (ccl::last-frame-ptr))
99                                                       (ccl::last-frame-ptr))
100                                                     (ccl::%current-tcr)
101                                                     condition
102                                                     (ccl::%current-frame-ptr)
103                                                     #+ppc-target ccl::*fake-stack-frames*
104                                                     #+x86-target (ccl::%current-frame-ptr)
105                                                     (ccl::db-link)
106                                                     (1+ ccl::*break-level*)))
107                   (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
108              (format t "~%~%*** Error in event process: ~a~%~%" condition)
109              (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer)
110              (format t "~%~%~%")
111              (force-output t)
112              )))))))
113
114
115(defloadvar *default-ns-application-proxy-class-name*
116    "LispApplicationDelegate")
117
118
119#+apple-objc
120(defun enable-foreground ()
121  (rlet ((psn :<P>rocess<S>erial<N>umber))
122    (#_GetCurrentProcess psn)
123    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
124    (eql 0 (#_SetFrontProcess psn))))
125
126#+nil
127(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
128  (declare (ignore sender))
129  (#/show (#/sharedPanel lisp-preferences-panel)))
130
131(objc:defmethod (#/toggleConsole: :void) ((self lisp-application) sender)
132  (let* ((console (console self)))
133    (unless (%null-ptr-p console)
134      (mark-console-output-available console nil)
135      (if (setf (console-window-hidden-by-user console) (#/isVisible console))
136        (#/orderOut: console sender)
137        (#/orderFront: console sender)))))
138
139(objc:defmethod (#/validateMenuItem: :<BOOL>) ((self lisp-application)
140                                               item)
141  (let* ((action (#/action item)))
142    (cond ((eql action (@selector #/toggleConsole:))
143           (let* ((console (console self)))
144             (unless (%null-ptr-p console)
145               (if (#/isVisible console)
146                 (#/setTitle: item #@"Hide System Console")
147                 (#/setTitle: item #@"Show System Console"))
148               t)))
149          (t (call-next-method item)))))
150
151(defmethod ccl::process-exit-application ((process appkit-process) thunk)
152  (when (eq process ccl::*initial-process*)
153    (%set-toplevel thunk)
154    (#/terminate: *NSApp* +null-ptr+)))
155
156(defun run-event-loop ()
157  (%set-toplevel nil)
158  (change-class *cocoa-event-process* 'appkit-process)
159  (event-loop))
160
161(defun stop-event-loop ()
162  (#/stop: *nsapp* +null-ptr+))
163
164(defun event-loop (&optional end-test)
165  (let* ((app *NSApp*)
166         (thread ccl::*current-process*))
167    (loop
168      (if (not (slot-value thread 'have-interactive-terminal-io))
169        (let* ((ccl::*break-on-errors* nil))
170          (handler-case (let* ((*event-process-reported-conditions* nil))
171                          (if end-test
172                            (#/run app)
173                          #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
174                          #&NSDefaultRunLoopMode
175                          (#/distantFuture ns:ns-date))|#
176                          (#/run app)))
177            (error (c) (nslog-condition c))))
178        (with-simple-restart (abort "Process the next event")
179          (#/run app)))
180      #+debug (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
181      (when (or (and end-test (funcall end-test))
182                (and ccl::*quitting* (not (#/isRunning app))))
183        (return)))))
184
185(defun start-cocoa-application (&key
186                                (application-proxy-class-name
187                                 *default-ns-application-proxy-class-name*))
188 
189  (flet ((cocoa-startup ()
190           ;; Start up a thread to run periodic tasks.
191           (process-run-function "housekeeping" #'ccl::housekeeping-loop)
192           (with-autorelease-pool
193             (enable-foreground)
194             (or *NSApp* (setq *NSApp* (init-cocoa-application)))
195             (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
196               (unless (%null-ptr-p icon)
197                 (#/setApplicationIconImage: *NSApp* icon)))
198             (setf (ccl::application-ui-object *application*) *NSApp*)
199             (when application-proxy-class-name
200               (let* ((classptr (ccl::%objc-class-classptr
201                                 (ccl::load-objc-class-descriptor application-proxy-class-name)))
202                      (instance (#/init (#/alloc classptr))))
203
204                 (#/setDelegate: *NSApp* instance))))
205           (run-event-loop)))
206    (process-interrupt *cocoa-event-process* #'(lambda ()
207                                                 (%set-toplevel 
208                                                  #'cocoa-startup)
209                                                 (toplevel)))))
210
211(defparameter *font-attribute-names*
212  '((:bold . #.#$NSBoldFontMask)
213    (:italic . #.#$NSItalicFontMask)
214    (:small-caps . #.#$NSSmallCapsFontMask)))
215
216
217;;; The NSFont method #/isFixedPitch has returned random answers
218;;; in many cases for the last few OSX releases.  Try to return
219;;; a reasonable answer, by checking to see if the width of the
220;;; advancement for the #\i glyph matches that of the advancement
221;;; of the #\m glyph.
222
223(defun is-fixed-pitch-font (font)
224  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
225     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))
226
227;;; Try to find the specified font.  If it doesn't exist (or isn't
228;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
229(defun default-font (&key (name *default-font-name*)
230                          (size *default-font-size*)
231                          (attributes ()))
232                               
233  (setq size (cgfloat size))
234  (with-cstrs ((name name))
235    (with-autorelease-pool
236        (rletz ((matrix (:array :<CGF>loat 6)))
237          (setf (paref matrix (:* :<CGF>loat) 0) size
238                (paref matrix (:* :<CGF>loat) 3) size)
239          (let* ((fontname (#/stringWithCString: ns:ns-string name))
240                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
241                 
242                 (implemented-attributes ()))
243            (if (or (%null-ptr-p font)
244                    (and 
245                     (not (is-fixed-pitch-font font))))
246              (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
247            (when attributes
248              (dolist (attr-name attributes)
249                (let* ((pair (assoc attr-name *font-attribute-names*))
250                       (newfont))
251                  (when pair
252                    (setq newfont
253                          (#/convertFont:toHaveTrait:
254                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
255                    (unless (eql font newfont)
256                      (setq font newfont)
257                      (push attr-name implemented-attributes))))))
258            (values (#/retain font) implemented-attributes))))))
259
260
261;;; Create a paragraph style, mostly so that we can set tabs reasonably.
262(defun create-paragraph-style (font line-break-mode)
263  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
264         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
265    (#/setLineBreakMode: p
266                         (ecase line-break-mode
267                           (:char #$NSLineBreakByCharWrapping)
268                           (:word #$NSLineBreakByWordWrapping)
269                           ;; This doesn't seem to work too well.
270                           ((nil) #$NSLineBreakByClipping)))
271    ;; Clear existing tab stops.
272    (#/setTabStops: p (#/array ns:ns-array))
273    ;; And set the "default tab interval".
274    (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth)))
275    p))
276   
277(defun create-text-attributes (&key (font (default-font))
278                                    (line-break-mode :char)
279                                    (color nil)
280                                    (obliqueness nil)
281                                    (stroke-width nil))
282  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
283    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
284                         #&NSParagraphStyleAttributeName)
285    (#/setObject:forKey: dict font #&NSFontAttributeName)
286    (when color
287      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
288    (when stroke-width
289      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
290                           #&NSStrokeWidthAttributeName))
291    (when obliqueness
292      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
293                           #&NSObliquenessAttributeName))
294    dict))
295
296
297(defun get-cocoa-window-flag (w flagname)
298  (case flagname
299    (:accepts-mouse-moved-events
300     (#/acceptsMouseMovedEvents w))
301    (:cursor-rects-enabled
302     (#/areCursorRectsEnabled w))
303    (:auto-display
304     (#/isAutodisplay w))))
305
306
307
308(defun (setf get-cocoa-window-flag) (value w flagname)
309  (case flagname
310    (:accepts-mouse-moved-events
311     (#/setAcceptsMouseMovedEvents: w value))
312    (:auto-display
313     (#/setAutodisplay: w value))))
314
315
316
317(defun activate-window (w)
318  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
319  (#/makeKeyAndOrderFront: w nil))
320
321(defun set-window-title (window title)
322  (#/setTitle: window (if title
323                        (if (typep title 'ns:ns-string)
324                          title
325                          (%make-nsstring title))
326                        #@"") ))
327
328(defun new-cocoa-window (&key
329                         (class (find-class 'ns:ns-window))
330                         (title nil)
331                         (x 200.0)
332                         (y 200.0)
333                         (height 200.0)
334                         (width 500.0)
335                         (closable t)
336                         (iconifyable t)
337                         (metal nil)
338                         (expandable t)
339                         (backing :buffered)
340                         (defer t)
341                         (accepts-mouse-moved-events nil)
342                         (auto-display t)
343                         (activate t))
344  (ns:with-ns-rect (frame x y width height)
345    (let* ((stylemask
346            (logior #$NSTitledWindowMask
347                    (if closable #$NSClosableWindowMask 0)
348                    (if iconifyable #$NSMiniaturizableWindowMask 0)
349                    (if expandable #$NSResizableWindowMask 0)
350                    (if metal #$NSTexturedBackgroundWindowMask 0)))
351           (backing-type
352            (ecase backing
353              ((t :retained) #$NSBackingStoreRetained)
354              ((nil :nonretained) #$NSBackingStoreNonretained)
355              (:buffered #$NSBackingStoreBuffered)))
356           (w (make-instance
357               class
358               :with-content-rect frame
359               :style-mask stylemask
360               :backing backing-type
361               :defer defer)))
362      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
363            accepts-mouse-moved-events
364            (get-cocoa-window-flag w :auto-display)
365            auto-display)
366      (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
367      (when activate (activate-window w))
368      (when title (set-window-title w title))
369      w)))
370
371
372
373
Note: See TracBrowser for help on using the repository browser.