source: trunk/ccl/cocoa-ide/cocoa-window.lisp @ 7698

Last change on this file since 7698 was 7698, checked in by gz, 14 years ago

A new package and a reorg:

I put all the cocoa-ide files (except for a greatly stripped-down
cocoa.lisp and cocoa-application.lisp) in a new package named "GUI".

The package is defined in defsystem.lisp, which also defines a
function to load all the files explicitly, putting the fasls in
cocoa-ide;fasls; I stripped out all pretense that the files can or
should be loaded individually. Also, it is no longer necessary or
appropriate to compile hemlock separately, as it now compiles as
needed as part of the normal loading sequence. (Over time I am hoping
to get hemlock more and more integrated into the IDE, and having to
maintain it as if it still were a separate package is an unnecessary
burden).

Updated the README file appropriately.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.3 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(defstatic *appkit-process-interrupt-ids* (make-id-map))
53(defun register-appkit-process-interrupt (thunk)
54  (assign-id-map-id *appkit-process-interrupt-ids* thunk))
55(defun appkit-interrupt-function (id)
56  (id-map-free-object *appkit-process-interrupt-ids* id))
57
58(defclass appkit-process (process) ())
59
60(defconstant process-interrupt-event-subtype 17)
61
62
63
64
65(defclass lisp-application (ns:ns-application)
66    ((termp :foreign-type :<BOOL>))
67  (:metaclass ns:+ns-object))
68
69
70(objc:defmethod (#/postEventAtStart: :void) ((self  ns:ns-application) e)
71  (#/postEvent:atStart: self e t))
72
73;;; Interrupt the AppKit event process, by enqueing an event (if the
74;;; application event loop seems to be running.)  It's possible that
75;;; the event loop will stop after the calling thread checks; in that
76;;; case, the application's probably already in the process of
77;;; exiting, and isn't that different from the case where asynchronous
78;;; interrupts are used.  An attribute of the event is used to identify
79;;; the thunk which the event handler needs to funcall.
80(defmethod process-interrupt ((process appkit-process) function &rest args)
81  (if (eq process *current-process*)
82    (apply function args)
83    (if (or (not *NSApp*) (not (#/isRunning *NSApp*)))
84      (call-next-method)
85        (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
86                   ns:ns-event
87                   #$NSApplicationDefined
88                   (ns:make-ns-point 0 0)
89                   0
90                   0.0d0
91                   0
92                   +null-ptr+
93                   process-interrupt-event-subtype
94                   (register-appkit-process-interrupt
95                    #'(lambda () (apply function args))) 0)))
96        (#/retain e)
97        (#/performSelectorOnMainThread:withObject:waitUntilDone:
98         *NSApp* (@selector "postEventAtStart:") e  t)))))
99
100
101(defparameter *debug-in-event-process* t)
102
103(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")
104
105(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer)
106  "Better than nothing.  Not much better."
107  (when *debug-in-event-process*
108    (let* ((c (if (typep condition 'ccl::ns-lisp-exception)
109                (ccl::ns-lisp-exception-condition condition)
110                condition)))
111      (unless (member c *event-process-reported-conditions*)
112        (push c *event-process-reported-conditions*)
113        (catch 'need-a-catch-frame-for-backtrace
114          (let* ((*debug-in-event-process* nil)
115                 (context (ccl::new-backtrace-info nil
116                                                   frame-pointer
117                                                   (if ccl::*backtrace-contexts*
118                                                       (or (ccl::child-frame
119                                                            (ccl::bt.youngest (car ccl::*backtrace-contexts*))
120                                                            nil)
121                                                           (ccl::last-frame-ptr))
122                                                       (ccl::last-frame-ptr))
123                                                   (ccl::%current-tcr)
124                                                   condition
125                                                   (ccl::%current-frame-ptr)
126                                                   #+ppc-target ccl::*fake-stack-frames*
127                                                   #+x86-target (ccl::%current-frame-ptr)
128                                                   (ccl::db-link)
129                                                   (1+ ccl::*break-level*)))
130                 (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
131            (format t "~%~%*** Error in event process: ~a~%~%" condition)
132            (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer)
133            (format t "~%~%~%")
134            (force-output t)
135            ))))))
136
137
138(defloadvar *default-ns-application-proxy-class-name*
139    "LispApplicationDelegate")
140
141
142#+apple-objc
143(defun enable-foreground ()
144  (rlet ((psn :<P>rocess<S>erial<N>umber))
145    (#_GetCurrentProcess psn)
146    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
147    (eql 0 (#_SetFrontProcess psn))))
148
149;;; I'm not sure if there's another way to recognize events whose
150;;; type is #$NSApplicationDefined.
151(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
152  (if (and (eql (#/type e) #$NSApplicationDefined)
153           (eql (#/subtype e)  process-interrupt-event-subtype))
154    ;;; The thunk to funcall is identified by the value
155    ;;; of the event's data1 attribute.
156    (funcall (appkit-interrupt-function (#/data1 e)))
157    (call-next-method e)))
158
159#+nil
160(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
161  (declare (ignore sender))
162  (#/show (#/sharedPanel lisp-preferences-panel)))
163
164(objc:defmethod (#/toggleTypeout: :void) ((self lisp-application) sender)
165  (declare (ignore sender))
166  (#/show (#/sharedPanel typeout-window)))
167
168(defun nslog-condition (c)
169  (let* ((rep (format nil "~a" c)))
170    (with-cstrs ((str rep))
171      (with-nsstr (nsstr str (length rep))
172        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
173
174
175(defmethod ccl::process-exit-application ((process appkit-process) thunk)
176  (when (eq process ccl::*initial-process*)
177    (%set-toplevel thunk)
178    (#/terminate: *NSApp* +null-ptr+)))
179
180(defun run-event-loop ()
181  (%set-toplevel nil)
182  (change-class *cocoa-event-process* 'appkit-process)
183  (let* ((app *NSApp*))
184    (loop
185        (handler-case (let* ((*event-process-reported-conditions* nil))
186                        (#/run app))
187          (error (c) (nslog-condition c)))
188        (unless (#/isRunning app)
189          (return)))))
190
191
192
193(defun start-cocoa-application (&key
194                                (application-proxy-class-name
195                                 *default-ns-application-proxy-class-name*))
196 
197  (flet ((cocoa-startup ()
198           ;; Start up a thread to run periodic tasks.
199           (process-run-function "housekeeping"
200                                 #'(lambda ()
201                                     (loop
202                                       (ccl::%nanosleep ccl::*periodic-task-seconds*
203                                                        ccl::*periodic-task-nanoseconds*)
204                                       (ccl::housekeeping))))
205           
206           (with-autorelease-pool
207             (enable-foreground)
208             (or *NSApp* (setq *NSApp* (init-cocoa-application)))
209             (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
210               (unless (%null-ptr-p icon)
211                 (#/setApplicationIconImage: *NSApp* icon)))
212             (setf (ccl::application-ui-object *application*) *NSApp*)
213             (when application-proxy-class-name
214               (let* ((classptr (ccl::%objc-class-classptr
215                                 (ccl::load-objc-class-descriptor application-proxy-class-name)))
216                      (instance (#/init (#/alloc classptr))))
217
218                 (#/setDelegate: *NSApp* instance))))
219           (run-event-loop)))
220    (process-interrupt *cocoa-event-process* #'(lambda ()
221                                                 (%set-toplevel 
222                                                  #'cocoa-startup)
223                                                 (toplevel)))))
224
225(defparameter *font-attribute-names*
226  '((:bold . #.#$NSBoldFontMask)
227    (:italic . #.#$NSItalicFontMask)
228    (:small-caps . #.#$NSSmallCapsFontMask)))
229
230
231;;; The NSFont method #/isFixedPitch has returned random answers
232;;; in many cases for the last few OSX releases.  Try to return
233;;; a reasonable answer, by checking to see if the width of the
234;;; advancement for the #\i glyph matches that of the advancement
235;;; of the #\m glyph.
236
237(defun is-fixed-pitch-font (font)
238  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
239     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))
240
241;;; Try to find the specified font.  If it doesn't exist (or isn't
242;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
243(defun default-font (&key (name *default-font-name*)
244                          (size *default-font-size*)
245                          (attributes ()))
246                               
247  (setq size (cgfloat size))
248  (with-cstrs ((name name))
249    (with-autorelease-pool
250        (rletz ((matrix (:array :<CGF>loat 6)))
251          (setf (paref matrix (:* :<CGF>loat) 0) size
252                (paref matrix (:* :<CGF>loat) 3) size)
253          (let* ((fontname (#/stringWithCString: ns:ns-string name))
254                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
255                 
256                 (implemented-attributes ()))
257            (if (or (%null-ptr-p font)
258                    (and 
259                     (not (is-fixed-pitch-font font))))
260              (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
261            (when attributes
262              (dolist (attr-name attributes)
263                (let* ((pair (assoc attr-name *font-attribute-names*))
264                       (newfont))
265                  (when pair
266                    (setq newfont
267                          (#/convertFont:toHaveTrait:
268                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
269                    (unless (eql font newfont)
270                      (setq font newfont)
271                      (push attr-name implemented-attributes))))))
272            (values (#/retain font) implemented-attributes))))))
273
274
275;;; Create a paragraph style, mostly so that we can set tabs reasonably.
276(defun create-paragraph-style (font line-break-mode)
277  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
278         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
279    (#/setLineBreakMode: p
280                         (ecase line-break-mode
281                           (:char #$NSLineBreakByCharWrapping)
282                           (:word #$NSLineBreakByWordWrapping)
283                           ;; This doesn't seem to work too well.
284                           ((nil) #$NSLineBreakByClipping)))
285    ;; Clear existing tab stops.
286    (#/setTabStops: p (#/array ns:ns-array))
287    ;; And set the "default tab interval".
288    (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth)))
289    p))
290   
291(defun create-text-attributes (&key (font (default-font))
292                                    (line-break-mode :char)
293                                    (color nil)
294                                    (obliqueness nil)
295                                    (stroke-width nil))
296  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
297    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
298                         #&NSParagraphStyleAttributeName)
299    (#/setObject:forKey: dict font #&NSFontAttributeName)
300    (when color
301      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
302    (when stroke-width
303      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
304                           #&NSStrokeWidthAttributeName))
305    (when obliqueness
306      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
307                           #&NSObliquenessAttributeName))
308    dict))
309
310
311(defun get-cocoa-window-flag (w flagname)
312  (case flagname
313    (:accepts-mouse-moved-events
314     (#/acceptsMouseMovedEvents w))
315    (:cursor-rects-enabled
316     (#/areCursorRectsEnabled w))
317    (:auto-display
318     (#/isAutodisplay w))))
319
320
321
322(defun (setf get-cocoa-window-flag) (value w flagname)
323  (case flagname
324    (:accepts-mouse-moved-events
325     (#/setAcceptsMouseMovedEvents: w value))
326    (:auto-display
327     (#/setAutodisplay: w value))))
328
329
330
331(defun activate-window (w)
332  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
333  (#/makeKeyAndOrderFront: w nil))
334
335(defun set-window-title (window title)
336  (#/setTitle: window (if title
337                        (if (typep title 'ns:ns-string)
338                          title
339                          (%make-nsstring title))
340                        #@"") ))
341
342(defun new-cocoa-window (&key
343                         (class (find-class 'ns:ns-window))
344                         (title nil)
345                         (x 200.0)
346                         (y 200.0)
347                         (height 200.0)
348                         (width 500.0)
349                         (closable t)
350                         (iconifyable t)
351                         (metal nil)
352                         (expandable t)
353                         (backing :buffered)
354                         (defer t)
355                         (accepts-mouse-moved-events nil)
356                         (auto-display t)
357                         (activate t))
358  (ns:with-ns-rect (frame x y width height)
359    (let* ((stylemask
360            (logior #$NSTitledWindowMask
361                    (if closable #$NSClosableWindowMask 0)
362                    (if iconifyable #$NSMiniaturizableWindowMask 0)
363                    (if expandable #$NSResizableWindowMask 0)
364                    (if metal #$NSTexturedBackgroundWindowMask 0)))
365           (backing-type
366            (ecase backing
367              ((t :retained) #$NSBackingStoreRetained)
368              ((nil :nonretained) #$NSBackingStoreNonretained)
369              (:buffered #$NSBackingStoreBuffered)))
370           (w (make-instance
371               class
372               :with-content-rect frame
373               :style-mask stylemask
374               :backing backing-type
375               :defer defer)))
376      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
377            accepts-mouse-moved-events
378            (get-cocoa-window-flag w :auto-display)
379            auto-display)
380      (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
381      (when activate (activate-window w))
382      (when title (set-window-title w title))
383      w)))
384
385
386
387
Note: See TracBrowser for help on using the repository browser.