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

Last change on this file since 15028 was 15028, checked in by gz, 9 years ago

First steps of remote debugging support. Note this is not complete and is not hooked up to anything yet, but if you manually set it up (see comment at top of cocoa-remote-lisp.lisp), the basic remote repl works.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 21.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(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(defmethod allocate-instance ((class ns:+ns-window)
349                              &rest initargs
350                              &key
351                              (with-content-rect nil content-rect-p)
352                              (style-mask 0 style-mask-p)
353                              (x 200)
354                              (y 200)
355                              (width 500)
356                              (height 200)
357                              (closable t)
358                              (iconifyable t)
359                              (expandable t)
360                              (metal nil)
361                              (backing :buffered)
362                              (defer t defer-p)
363                              &allow-other-keys)
364  (declare (ignore defer with-content-rect))
365  (unless content-rect-p
366    (setq initargs (cons :with-content-rect
367                         (cons (ns:make-ns-rect x y width height)
368                               initargs))))
369  (unless (and style-mask-p (typep style-mask 'fixnum))
370    (setq initargs (cons :style-mask
371                         (cons (logior #$NSTitledWindowMask
372                                       (if closable #$NSClosableWindowMask 0)
373                                       (if iconifyable #$NSMiniaturizableWindowMask 0)
374                                       (if expandable #$NSResizableWindowMask 0)
375                                       (if metal #$NSTexturedBackgroundWindowMask 0))
376                               initargs))))
377  (unless (typep (getf initargs :backing) 'fixnum)
378    (setq initargs
379          (cons :backing
380                (cons (ecase backing
381                        ((t :retained) #$NSBackingStoreRetained)
382                        ((nil :nonretained) #$NSBackingStoreNonretained)
383                        (:buffered #$NSBackingStoreBuffered))
384                      initargs))))
385  (unless defer-p
386    (setq initargs (cons :defer (cons t initargs))))
387  (apply #'call-next-method class initargs))
388
389(defmethod initialize-instance :after ((w ns:ns-window)
390                                       &key
391                                       (title nil)
392                                       (x 200.0)
393                                       (y 200.0)
394                                       (height 200.0)
395                                       (width 500.0)
396                                       (closable t)
397                                       (iconifyable t)
398                                       (metal nil)
399                                       (expandable t)
400                                       (backing :buffered)
401                                       (defer t)
402                                       (accepts-mouse-moved-events nil)
403                                       (auto-display t)
404                                       (activate nil)
405                                       &allow-other-keys)
406  ;; Several of the keyword args we claim to accept are actually processed
407  ;; by the ALLOCATE-INSTANCE method above and are ignored here.
408  (declare (ignore x y width height closable iconifyable expandable metal
409                   backing defer))
410  (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
411        accepts-mouse-moved-events
412        (get-cocoa-window-flag w :auto-display)
413        auto-display)
414  ;;; Should maybe have a way of controlling this.
415  (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
416  (when title
417    (set-window-title w title))
418  (when activate
419    (activate-window w)))
420
421
422(defmethod allocate-instance ((class ns:+ns-view)
423                              &rest initargs
424                              &key
425                              (with-frame nil with-frame-p)
426                              (x 0)
427                              (y 0)
428                              (width 0)
429                              (height 0)
430                              &allow-other-keys)
431  (declare (ignorable with-frame))
432  (unless with-frame-p
433    (setq initargs (cons :with-frame
434                         (cons (ns:make-ns-rect x y width height) initargs))))
435  (apply #'call-next-method class initargs))
436
437
438(defmethod initialize-instance :after ((view ns:ns-view)
439                                       &key
440                                       (horizontally-resizable nil hrp)
441                                       (vertically-resizable nil vrp)
442                                       (max-x-margin nil maxxp)
443                                       (min-x-margin nil minxp)
444                                       (max-y-margin nil maxyp)
445                                       (min-y-margin nil minyp)
446                                       (resizes-subviews t rsp)
447                                       view-container
448                                       &allow-other-keys)
449  (let* ((mask (#/autoresizingMask view))
450         (newmask mask))
451    (when hrp
452      (setq newmask (if horizontally-resizable
453                      (logior newmask #$NSViewWidthSizable)
454                      (logandc2 newmask #$NSViewWidthSizable))))
455    (when vrp
456      (setq newmask (if vertically-resizable
457                      (logior newmask #$NSViewHeightSizable)
458                      (logandc2 newmask #$NSViewHeightSizable))))
459    (when minxp
460      (setq newmask (if min-x-margin
461                      (logior newmask #$NSViewMinXMargin)
462                      (logandc2 newmask #$NSViewMinXMargin))))
463    (when maxxp
464      (setq newmask (if max-x-margin
465                      (logior newmask #$NSViewMaxXMargin)
466                      (logandc2 newmask #$NSViewMaxXMargin))))
467    (when minyp
468      (setq newmask (if min-y-margin
469                      (logior newmask #$NSViewMinYMargin)
470                      (logandc2 newmask #$NSViewMinYMargin))))
471    (when maxyp
472      (setq newmask (if max-y-margin
473                      (logior newmask #$NSViewMaxYMargin)
474                      (logandc2 newmask #$NSViewMaxYMargin))))
475    (unless (eql mask newmask)
476      (#/setAutoresizingMask: view newmask)))
477  (when rsp
478    (#/setAutoresizesSubviews: view resizes-subviews))
479  (when view-container
480    (install-view-in-container view view-container)))
481                             
482
483(defun new-cocoa-window (&key
484                         (class (find-class 'ns:ns-window))
485                         (title nil)
486                         (x 200.0)
487                         (y 200.0)
488                         (height 200.0)
489                         (width 500.0)
490                         (closable t)
491                         (iconifyable t)
492                         (metal nil)
493                         (expandable t)
494                         (backing :buffered)
495                         (defer t)
496                         (accepts-mouse-moved-events nil)
497                         (auto-display t)
498                         (activate t))
499  (make-instance class
500                 :title title
501                 :x x
502                 :y y
503                 :height height
504                 :width width
505                 :closable closable
506                 :iconifyable iconifyable
507                 :metal metal
508                 :expandable expandable
509                 :backing backing
510                 :defer defer
511                 :accepts-mouse-moved-events accepts-mouse-moved-events
512                 :auto-display auto-display
513                 :activate activate))
514
515(defmethod view-window ((view ns:ns-view))
516  (let* ((w (#/window view)))
517    (unless (%null-ptr-p w)
518      w)))
519
520(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-view))
521  (#/addSubview: container view))
522
523(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-window))
524  (#/addSubview: (#/contentView container) view))
Note: See TracBrowser for help on using the repository browser.