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

Last change on this file since 15345 was 15345, checked in by rme, 8 years ago

Introduce new ide-window and ide-view classes and use them for now.
This avoids adding new behavior to the NSWindow class, which
other code typically doesn't expect.

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