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

Last change on this file since 14311 was 14311, checked in by gb, 9 years ago

SET-VIEW-CONTAINER methods, :VIEW-CONTAINER arg to NSView INITIALIZE-INSTANCE
method.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.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(defclass appkit-process (process)
53    ((have-interactive-terminal-io :initform t)))
54
55(defmethod event-loop-can-have-interactive-terminal-io ((process appkit-process))
56  #+windows-target t
57  #-windows-target (slot-value process 'have-interactive-terminal-io))
58
59;;; Interrupt the AppKit event process, by enqueing an event (if the
60;;; application event loop seems to be running.)  It's possible that
61;;; the event loop will stop after the calling thread checks; in that
62;;; case, the application's probably already in the process of
63;;; exiting, and isn't that different from the case where asynchronous
64;;; interrupts are used.
65(defmethod process-interrupt ((process appkit-process) function &rest args)
66  (if (eq process *current-process*)
67    (apply function args)
68    (if (and *NSApp* (#/isRunning *NSApp*))
69      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
70      #+not-yet
71      (let* ((invoked nil)
72             (f (lambda ()
73                  (unless invoked
74                    (setq invoked t)
75                    (apply function args)))))
76        (queue-for-gui f :at-start t)
77        (call-next-method process f))
78      (call-next-method))))
79
80(defparameter *debug-in-event-process* t)
81
82(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")
83
84(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer)
85  "Better than nothing.  Not much better."
86  (when *debug-in-event-process*
87    (let* ((c (if (typep condition 'ccl::ns-lisp-exception)
88                (ccl::ns-lisp-exception-condition condition)
89                condition)))
90      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
91        (push c *event-process-reported-conditions*)
92        (cond ((slot-value process 'have-interactive-terminal-io)
93               (ccl::application-error ccl::*application* c frame-pointer))
94              (t
95               (catch 'need-a-catch-frame-for-backtrace
96                 (let* ((*debug-in-event-process* nil)
97                        (context
98                         (ccl::new-backtrace-info nil
99                                                  frame-pointer
100                                                  (if ccl::*backtrace-contexts*
101                                                      (or (ccl::child-frame
102                                                           (ccl::bt.youngest
103                                                            (car ccl::*backtrace-contexts*))
104                                                           nil)
105                                                          (ccl::last-frame-ptr))
106                                                      (ccl::last-frame-ptr))
107                                                  (ccl::%current-tcr)
108                                                  condition
109                                                  (ccl::%current-frame-ptr)
110                                                  #+ppc-target ccl::*fake-stack-frames*
111                                                  #+x86-target (ccl::%current-frame-ptr)
112                                                  (ccl::db-link)
113                                                  (1+ ccl::*break-level*)))
114                        (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
115                   (format t "~%~%*** Error in event process: ~a~%~%" condition)
116                   (print-call-history :context context :detailed-p t :count 20
117                                       :origin frame-pointer)
118                   (format t "~%~%~%")
119                   (force-output t)
120                   ))))))))
121
122
123
124(defloadvar *default-ns-application-proxy-class-name*
125    "LispApplicationDelegate")
126
127
128(defun enable-foreground ()
129  #+apple-objc
130  (rlet ((psn :<P>rocess<S>erial<N>umber))
131    (#_GetCurrentProcess psn)
132    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
133    (eql 0 (#_SetFrontProcess psn))))
134
135#+nil
136(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
137  (declare (ignore sender))
138  (#/show (#/sharedPanel lisp-preferences-panel)))
139
140(objc:defmethod (#/toggleConsole: :void) ((self lisp-application) sender)
141  (let* ((console (console self)))
142    (unless (%null-ptr-p console)
143      (mark-console-output-available console nil)
144      (if (setf (console-window-hidden-by-user console) (#/isVisible console))
145        (#/orderOut: console sender)
146        (#/orderFront: console sender)))))
147
148(objc:defmethod (#/validateMenuItem: :<BOOL>) ((self lisp-application)
149                                               item)
150  (let* ((action (#/action item)))
151    (cond ((eql action (@selector #/toggleConsole:))
152           (let* ((console (console self)))
153             (unless (%null-ptr-p console)
154               (if (#/isVisible console)
155                 (#/setTitle: item #@"Hide System Console")
156                 (#/setTitle: item #@"Show System Console"))
157               t)))
158          (t #+cocotron t #-cocotron (call-next-method item)))))
159
160(defmethod ccl::process-exit-application ((process appkit-process) thunk)
161  (when (eq process ccl::*initial-process*)
162    (%set-toplevel thunk)
163    (#/terminate: *NSApp* +null-ptr+)))
164
165(defun run-event-loop ()
166  (%set-toplevel nil)
167  (change-class *cocoa-event-process* 'appkit-process)
168  (event-loop))
169
170(defun stop-event-loop ()
171  (#/stop: *nsapp* +null-ptr+))
172
173(defun event-loop (&optional end-test)
174  (let* ((app *NSApp*)
175         (thread ccl::*current-process*))
176    (loop
177      (if (event-loop-can-have-interactive-terminal-io thread)
178        (with-simple-restart (abort "Process the next event")
179          (#/run app))
180        (let* ((ccl::*break-on-errors* nil))
181          (handler-case (let* ((*event-process-reported-conditions* nil))
182                          (if end-test
183                            (#/run app)
184                            #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
185                                                     #&NSDefaultRunLoopMode
186                                                     (#/distantFuture ns:ns-date))|#
187                            (#/run app)))
188            (error (c) (nslog-condition c)))))
189      #+debug (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
190      (when (or (and end-test (funcall end-test))
191                (and ccl::*quitting* (not (#/isRunning app))))
192        (return)))))
193
194(defun start-cocoa-application (&key
195                                (application-proxy-class-name
196                                 *default-ns-application-proxy-class-name*))
197 
198  (flet ((cocoa-startup ()
199           ;; Start up a thread to run periodic tasks.
200           (process-run-function "housekeeping" #'ccl::housekeeping-loop)
201           (with-autorelease-pool
202             (enable-foreground)
203             (or *NSApp* (setq *NSApp* (init-cocoa-application)))
204             #-cocotron
205             (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
206               (unless (%null-ptr-p icon)
207                 (#/setApplicationIconImage: *NSApp* icon)))
208             (setf (ccl::application-ui-object *application*) *NSApp*)
209             (when application-proxy-class-name
210               (let* ((classptr (ccl::%objc-class-classptr
211                                 (ccl::load-objc-class-descriptor application-proxy-class-name)))
212                      (instance (#/init (#/alloc classptr))))
213
214                 (#/setDelegate: *NSApp* instance))))
215           (run-event-loop)))
216    (process-interrupt *cocoa-event-process* #'(lambda ()
217                                                 (%set-toplevel 
218                                                  #'cocoa-startup)
219                                                 (toplevel)))))
220
221(defparameter *font-attribute-names*
222  '((:bold . #.#$NSBoldFontMask)
223    (:italic . #.#$NSItalicFontMask)
224    (:small-caps . #.#$NSSmallCapsFontMask)))
225
226
227;;; The NSFont method #/isFixedPitch has returned random answers
228;;; in many cases for the last few OSX releases.  Try to return
229;;; a reasonable answer, by checking to see if the width of the
230;;; advancement for the #\i glyph matches that of the advancement
231;;; of the #\m glyph.
232
233#-cocotron
234(defun is-fixed-pitch-font (font)
235  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
236     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))
237
238#+cocotron
239(defun is-fixed-pitch-font (font)
240  (#/isFixedPitch font))
241
242;;; Try to find the specified font.  If it doesn't exist (or isn't
243;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
244(defun default-font (&key (name *default-font-name*)
245                          (size *default-font-size*)
246                          (attributes ()))
247                               
248  (setq size (cgfloat size))
249  (with-cstrs ((name name))
250    (with-autorelease-pool
251        (rletz ((matrix (:array :<CGF>loat 6)))
252          (setf (paref matrix (:* :<CGF>loat) 0) size
253                (paref matrix (:* :<CGF>loat) 3) size)
254          (let* ((fontname (#/stringWithCString: ns:ns-string name))
255                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
256                 
257                 (implemented-attributes ()))
258            (if (or (%null-ptr-p font)
259                    (and 
260                     (not (is-fixed-pitch-font font))))
261              (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
262            (when attributes
263              (dolist (attr-name attributes)
264                (let* ((pair (assoc attr-name *font-attribute-names*))
265                       (newfont))
266                  (when pair
267                    (setq newfont
268                          (#/convertFont:toHaveTrait:
269                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
270                    (unless (eql font newfont)
271                      (setq font newfont)
272                      (push attr-name implemented-attributes))))))
273            (values (#/retain font) implemented-attributes))))))
274
275
276;;; Create a paragraph style, mostly so that we can set tabs reasonably.
277(defun create-paragraph-style (font line-break-mode)
278  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
279         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
280    (#/setLineBreakMode: p
281                         (ecase line-break-mode
282                           (:char #$NSLineBreakByCharWrapping)
283                           (:word #$NSLineBreakByWordWrapping)
284                           ;; This doesn't seem to work too well.
285                           ((nil) #$NSLineBreakByClipping)))
286    ;; Clear existing tab stops.
287    (#/setTabStops: p (#/array ns:ns-array))
288    ;; And set the "default tab interval".
289    (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth)))
290    p))
291   
292(defun create-text-attributes (&key (font (default-font))
293                                    (line-break-mode :char)
294                                    (color nil)
295                                    (obliqueness nil)
296                                    (stroke-width nil))
297  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
298    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
299                         #&NSParagraphStyleAttributeName)
300    (#/setObject:forKey: dict font #&NSFontAttributeName)
301    (when color
302      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
303    (when stroke-width
304      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
305                           #&NSStrokeWidthAttributeName))
306    (when obliqueness
307      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
308                           #&NSObliquenessAttributeName))
309    dict))
310
311
312(defun get-cocoa-window-flag (w flagname)
313  (case flagname
314    (:accepts-mouse-moved-events
315     (#/acceptsMouseMovedEvents w))
316    (:cursor-rects-enabled
317     (#/areCursorRectsEnabled w))
318    (:auto-display
319     (#/isAutodisplay w))))
320
321
322
323(defun (setf get-cocoa-window-flag) (value w flagname)
324  (case flagname
325    (:accepts-mouse-moved-events
326     (#/setAcceptsMouseMovedEvents: w value))
327    (:auto-display
328     (#/setAutodisplay: w value))))
329
330
331
332(defun activate-window (w)
333  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
334  (#/makeKeyAndOrderFront: w nil))
335
336(defun set-window-title (window title)
337  (#/setTitle: window (if title
338                        (if (typep title 'ns:ns-string)
339                          title
340                          (%make-nsstring title))
341                        #@"") ))
342
343(defmethod allocate-instance ((class ns:+ns-window)
344                              &rest initargs
345                              &key
346                              (with-content-rect nil content-rect-p)
347                              (style-mask 0 style-mask-p)
348                              (x 200)
349                              (y 200)
350                              (width 500)
351                              (height 200)
352                              (closable t)
353                              (iconifyable t)
354                              (expandable t)
355                              (metal nil)
356                              (backing :buffered)
357                              (defer t defer-p)
358                              &allow-other-keys)
359  (declare (ignore defer with-content-rect))
360  (unless content-rect-p
361    (setq initargs (cons :with-content-rect
362                         (cons (ns:make-ns-rect x y width height)
363                               initargs))))
364  (unless (and style-mask-p (typep style-mask 'fixnum))
365    (setq initargs (cons :style-mask
366                         (cons (logior #$NSTitledWindowMask
367                                       (if closable #$NSClosableWindowMask 0)
368                                       (if iconifyable #$NSMiniaturizableWindowMask 0)
369                                       (if expandable #$NSResizableWindowMask 0)
370                                       (if metal #$NSTexturedBackgroundWindowMask 0))
371                               initargs))))
372  (unless (typep (getf initargs :backing) 'fixnum)
373    (setq initargs
374          (cons :backing
375                (cons (ecase backing
376                        ((t :retained) #$NSBackingStoreRetained)
377                        ((nil :nonretained) #$NSBackingStoreNonretained)
378                        (:buffered #$NSBackingStoreBuffered))
379                      initargs))))
380  (unless defer-p
381    (setq initargs (cons :defer (cons t initargs))))
382  (apply #'call-next-method class initargs))
383
384(defmethod initialize-instance :after ((w ns:ns-window)
385                                       &key
386                                       (title nil)
387                                       (x 200.0)
388                                       (y 200.0)
389                                       (height 200.0)
390                                       (width 500.0)
391                                       (closable t)
392                                       (iconifyable t)
393                                       (metal nil)
394                                       (expandable t)
395                                       (backing :buffered)
396                                       (defer t)
397                                       (accepts-mouse-moved-events nil)
398                                       (auto-display t)
399                                       (activate nil)
400                                       &allow-other-keys)
401  ;; Several of the keyword args we claim to accept are actually processed
402  ;; by the ALLOCATE-INSTANCE method above and are ignored here.
403  (declare (ignore x y width height closable iconifyable expandable metal
404                   backing defer))
405  (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
406        accepts-mouse-moved-events
407        (get-cocoa-window-flag w :auto-display)
408        auto-display)
409  ;;; Should maybe have a way of controlling this.
410  (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
411  (when title
412    (set-window-title w title))
413  (when activate
414    (activate-window w)))
415
416
417(defmethod allocate-instance ((class ns:+ns-view)
418                              &rest initargs
419                              &key
420                              (with-frame nil with-frame-p)
421                              (x 0)
422                              (y 0)
423                              (width 0)
424                              (height 0)
425                              &allow-other-keys)
426  (unless with-frame-p
427    (setq initargs (cons :with-frame
428                         (cons (ns:make-ns-rect x y width height) initargs))))
429  (apply #'call-next-method class initargs))
430
431
432(defmethod initialize-instance :after ((view ns:ns-view)
433                                       &key
434                                       (horizontally-resizable nil hrp)
435                                       (vertically-resizable nil vrp)
436                                       (max-x-margin nil maxxp)
437                                       (min-x-margin nil minxp)
438                                       (max-y-margin nil maxyp)
439                                       (min-y-margin nil minyp)
440                                       (resizes-subviews t rsp)
441                                       view-container
442                                       &allow-other-keys)
443  (let* ((mask (#/autoresizingMask view))
444         (newmask mask))
445    (when hrp
446      (setq newmask (if horizontally-resizable
447                      (logior newmask #$NSViewWidthSizable)
448                      (logandc2 newmask #$NSViewWidthSizable))))
449    (when vrp
450      (setq newmask (if vertically-resizable
451                      (logior newmask #$NSViewHeightSizable)
452                      (logandc2 newmask #$NSViewHeightSizable))))
453    (when minxp
454      (setq newmask (if min-x-margin
455                      (logior newmask #$NSViewMinXMargin)
456                      (logandc2 newmask #$NSViewMinXMargin))))
457    (when maxxp
458      (setq newmask (if max-x-margin
459                      (logior newmask #$NSViewMaxXMargin)
460                      (logandc2 newmask #$NSViewMaxXMargin))))
461    (when minyp
462      (setq newmask (if min-y-margin
463                      (logior newmask #$NSViewMinYMargin)
464                      (logandc2 newmask #$NSViewMinYMargin))))
465    (when maxyp
466      (setq newmask (if max-y-margin
467                      (logior newmask #$NSViewMaxYMargin)
468                      (logandc2 newmask #$NSViewMaxYMargin))))
469    (unless (eql mask newmask)
470      (#/setAutoresizingMask: view newmask)))
471  (when rsp
472    (#/setAutoresizesSubviews: view resizes-subviews))
473  (when view-container
474    (install-view-in-container view view-container)))
475                             
476
477(defun new-cocoa-window (&key
478                         (class (find-class 'ns:ns-window))
479                         (title nil)
480                         (x 200.0)
481                         (y 200.0)
482                         (height 200.0)
483                         (width 500.0)
484                         (closable t)
485                         (iconifyable t)
486                         (metal nil)
487                         (expandable t)
488                         (backing :buffered)
489                         (defer t)
490                         (accepts-mouse-moved-events nil)
491                         (auto-display t)
492                         (activate t))
493  (make-instance class
494                 :title title
495                 :x x
496                 :y y
497                 :height height
498                 :width width
499                 :closable closable
500                 :iconifyable iconifyable
501                 :metal metal
502                 :expandable expandable
503                 :backing backing
504                 :defer defer
505                 :accepts-mouse-moved-events accepts-mouse-moved-events
506                 :auto-display auto-display
507                 :activate activate))
508
509(defmethod view-window ((view ns:ns-view))
510  (let* ((w (#/window view)))
511    (unless (%null-ptr-p w)
512      w)))
513
514(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-view))
515  (#/addSubview: container view))
516
517(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-window))
518  (#/addSubview: (#/contentView container) view))
Note: See TracBrowser for help on using the repository browser.