source: trunk/source/cocoa-ide/cocoa-utils.lisp @ 12022

Last change on this file since 12022 was 12022, checked in by rme, 11 years ago

Try to make the experimental apropos dialog work on Tiger.

File size: 15.7 KB
Line 
1; -*- Mode: Lisp; Package: GUI -*-
2
3(in-package "GUI")
4
5(defclass sequence-window-controller (ns:ns-window-controller)
6    ((table-view :foreign-type :id :reader sequence-window-controller-table-view)
7     (sequence :initform nil :initarg :sequence :type sequence :reader sequence-window-controller-sequence)
8     (result-callback :initarg :result-callback)
9     (display :initform #'(lambda (item stream) (prin1 item stream)) :initarg :display)
10     (title :initform "Sequence dialog" :initarg :title))
11  (:metaclass ns:+ns-object))
12
13
14(objc:defmethod #/init ((self sequence-window-controller))
15  (call-next-method)
16  (let* ((w (new-cocoa-window :activate nil))
17         (contentview (#/contentView w))
18         (contentframe (#/frame contentview))
19         (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe)))
20    (#/setWindow: self w)
21    (#/setDelegate: w self)
22    (#/setWindowController: w self)
23    (#/setHasVerticalScroller: scrollview t)
24    (#/setHasHorizontalScroller: scrollview t)
25    (#/setAutohidesScrollers: scrollview t)
26    (#/setRulersVisible: scrollview nil)
27    (#/setAutoresizingMask: scrollview (logior
28                                        #$NSViewWidthSizable
29                                        #$NSViewHeightSizable))
30    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
31    (let* ((table-view (make-instance 'ns:ns-table-view)))
32      (#/setDocumentView: scrollview table-view)
33      (#/release table-view)
34      (#/setColumnAutoresizingStyle: table-view #$NSTableViewUniformColumnAutoresizingStyle)
35      (setf (slot-value self 'table-view) table-view)
36      (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@"")))
37        (#/setEditable: column nil)
38        (#/setResizingMask: column #$NSTableColumnAutoresizingMask)
39        (#/addTableColumn: table-view column)
40        (#/release column))
41      (#/setAutoresizingMask: table-view (logior
42                                          #$NSViewWidthSizable
43                                          #$NSViewHeightSizable))
44      (#/sizeToFit table-view)
45      (#/setDataSource: table-view self)
46      (#/setTarget: table-view self)
47      (#/setHeaderView: table-view +null-ptr+)
48      (#/setUsesAlternatingRowBackgroundColors: table-view t)
49      (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:))
50      (#/addSubview: contentview scrollview)
51      (#/release scrollview)
52      self)))
53
54(objc:defmethod (#/dealloc :void) ((self sequence-window-controller))
55  (call-next-method))
56
57(objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller)
58                                            notification)
59  (declare (ignore notification))
60  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
61  (#/autorelease self))
62
63(objc:defmethod (#/sequenceDoubleClick: :void)
64    ((self sequence-window-controller) sender)
65  (let* ((n (#/clickedRow sender)))
66    (when (>= n 0)
67      (with-slots (sequence result-callback) self
68        (funcall result-callback (elt sequence n))))))
69
70(objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger)
71    ((self sequence-window-controller) view)
72  (declare (ignore view))
73  (length (slot-value self 'sequence)))
74
75
76(objc:defmethod #/tableView:objectValueForTableColumn:row:
77    ((self sequence-window-controller) view column (row :<NSI>nteger))
78  (declare (ignore column view))
79  (with-slots (display sequence) self
80    (#/autorelease
81     (%make-nsstring (with-output-to-string (s)
82                       (funcall display (elt sequence row) s))))))
83
84(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys)
85  (let* ((window (#/window self)))
86    (with-slots (title) self
87      (when title (#/setTitle: window (%make-nsstring title))))
88    (#/reloadData (sequence-window-controller-table-view self))
89    (#/performSelectorOnMainThread:withObject:waitUntilDone:
90     self
91     (@selector #/showWindow:)
92     +null-ptr+
93     nil)))
94
95;;; Looks like a "util" to me ...
96(defun pathname-to-url (pathname)
97  (make-instance 'ns:ns-url
98                 :file-url-with-path
99                 (%make-nsstring (native-translated-namestring pathname))))
100
101(defun cgfloat (number)
102  (float number ccl::+cgfloat-zero+))
103
104(defun color-values-to-nscolor (red green blue &optional alpha)
105  (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
106                                              (cgfloat red)
107                                              (cgfloat green)
108                                              (cgfloat blue)
109                                              (cgfloat (or alpha 1.0))))
110
111(defun map-windows (fn)
112  (let ((win-arr (#/orderedWindows *NSApp*)))
113    (dotimes (i (#/count win-arr))
114      (funcall fn (#/objectAtIndex: win-arr i)))))
115
116(defun windows ()
117  (let* ((ret nil))
118    (map-windows #'(lambda (w) (push w ret)))
119    (nreverse ret)))
120
121(defun first-window-satisfying-predicate (pred)
122  (block foo
123    (map-windows #'(lambda (w) (when (funcall pred w)
124                                 (return-from foo w)))))) 
125
126(defun first-window-with-controller-type (controller-type)
127  (first-window-satisfying-predicate #'(lambda (w) (typep (#/windowController w) controller-type))))
128
129;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
130;;
131
132(defvar *log-callback-errors* :backtrace)
133
134(defun maybe-log-callback-error (condition)
135  (when *log-callback-errors*
136    ;; Put these in separate ignore-errors, so at least some of it can get thru
137    (let ((emsg (ignore-errors (princ-to-string condition))))
138      (ignore-errors (clear-output *debug-io*))
139      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
140      (when (eq *log-callback-errors* :backtrace)
141        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
142          (when err
143            (ignore-errors (format *debug-io* "~&Error printing call history - "))
144            (ignore-errors (print err *debug-io*))
145            (ignore-errors (princ err *debug-io*))
146            (ignore-errors (force-output *debug-io*))))))))
147
148(defmacro with-callback-context (description &body body)
149  (let ((saved-debug-io (gensym)))
150    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
151       (let ((,saved-debug-io *debug-io*))
152         (handler-bind ((error #'(lambda (condition)
153                                   (let ((*debug-io* ,saved-debug-io))
154                                     (maybe-log-callback-error condition)
155                                     (abort)))))
156           ,@body)))))
157
158;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159;;
160;; utilities for executing in the cocoa event thread
161
162(defstatic *cocoa-thread-arg-id-map* (make-id-map))
163
164;; This is for debugging, it's preserved across queue-for-gui and bound
165;; so it can be seen in backtraces.
166(defvar *invoking-event-context* "unknown")
167(defvar *invoking-event-process* nil)
168
169(defun register-cocoa-thread-function (thunk result-handler context)
170  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
171                                                     result-handler
172                                                     (or context *invoking-event-context*)
173                                                     *current-process*)))
174
175(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
176  (invoke-lisp-function self id))
177
178(defmethod invoke-lisp-function ((self ns:ns-application) id)
179  (destructuring-bind (thunk result-handler context . invoking-process)
180                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
181    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
182
183(defun execute-in-gui (thunk &key context)
184  "Execute thunk in the main cocoa thread, return whatever values it returns"
185  (if (typep *current-process* 'appkit-process)
186    (handle-invoking-lisp-function thunk nil context)
187    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
188      (error "cocoa thread not available")
189      (let* ((return-values nil)
190             (result-handler #'(lambda (&rest values) (setq return-values values)))
191             (arg (make-instance 'ns:ns-number
192                    :with-long (register-cocoa-thread-function thunk result-handler context))))
193        (#/performSelectorOnMainThread:withObject:waitUntilDone:
194         *nsapp*
195         (@selector #/invokeLispFunction:)
196         arg
197         t)
198        (apply #'values return-values)))))
199
200
201(defconstant $lisp-function-event-subtype 17)
202
203(defclass lisp-application (ns:ns-application)
204    ((termp :foreign-type :<BOOL>)
205     (console :foreign-type :id :accessor console))
206  (:metaclass ns:+ns-object))
207
208(defmethod current-event-modifier-p (modifier-mask)
209  (let* ((event (#/currentEvent *nsapp*))
210         (modifiers (#/modifierFlags event)))
211    (logtest modifier-mask modifiers)))
212
213(defmethod current-event-command-key-p ()
214  (current-event-modifier-p #$NSCommandKeyMask))
215
216;;; I'm not sure if there's another way to recognize events whose
217;;; type is #$NSApplicationDefined.
218(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
219  (if (and (eql (#/type e) #$NSApplicationDefined)
220           (eql (#/subtype e) $lisp-function-event-subtype))
221    (invoke-lisp-function self (#/data1 e))
222    (call-next-method e)))
223
224;; This queues an event rather than just doing performSelectorOnMainThread, so that the
225;; action is deferred until the event thread is idle.
226(defun queue-for-gui (thunk &key result-handler context at-start)
227  "Queue thunk for execution in main cocoa thread and return immediately."
228  (execute-in-gui
229   #'(lambda () 
230       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
231                  ns:ns-event
232                  #$NSApplicationDefined
233                  (ns:make-ns-point 0 0)
234                  0
235                  0.0d0
236                  0
237                  +null-ptr+
238                  $lisp-function-event-subtype
239                  (register-cocoa-thread-function thunk result-handler context)
240                  0)))
241         ;(#/retain e)
242         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
243
244(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
245  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
246  (let* ((*invoking-event-process* invoking-process)
247         (*invoking-event-context* context))
248    (if result-handler
249      (multiple-value-call result-handler (funcall thunk))
250      (funcall thunk))))
251
252(defun choose-directory-dialog ()
253  (execute-in-gui #'(lambda ()
254                      (let ((op (#/openPanel ns:ns-open-panel)))
255                        (#/setAllowsMultipleSelection: op nil)
256                        (#/setCanChooseDirectories: op t)
257                        (#/setCanChooseFiles: op nil)
258                        (when (eql (#/runModalForTypes: op +null-ptr+) #$NSOKButton)
259                          ;; #/stringByStandardizingPath seems to strip trailing slashes
260                         (let* ((path (#/retain (#/stringByAppendingString:
261                                        (#/stringByStandardizingPath
262                                         (#/objectAtIndex: (#/filenames op) 0))
263                                        #@"/"))))
264                            path))))))
265
266
267;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
268;;
269;; debugging
270
271(defun double-%-in (string)
272  ;; Replace any % characters in string with %%, to keep them from
273  ;; being treated as printf directives.
274  (let* ((%pos (position #\% string)))
275    (if %pos
276      (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos))))
277      string)))
278
279(defun log-debug (format-string &rest args)
280  (let ((string (apply #'format nil format-string args)))
281    (#_NSLog (ccl::%make-nsstring (double-%-in string)))))
282
283(pushnew '(log-debug . 0) ccl::*format-arg-functions* :test #'equal)
284
285(defun nslog-condition (c)
286  (let* ((rep (format nil "~a" c)))
287    (with-cstrs ((str rep))
288      (with-nsstr (nsstr str (length rep))
289        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
290
291(defun nsstring-for-lisp-condition (cond)
292  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
293                                   "#<error printing error message>"))))
294
295
296
297(defun assume-cocoa-thread ()
298  (assert (eq *current-process* ccl::*initial-process*)))
299
300(defmethod assume-not-editing ((whatever t)))
301
302;;; -----------------------------------------------------------------
303;;; utility to display a Cocoa alert window
304;;; -----------------------------------------------------------------
305;;; TODO: Currently this form gives no indication which button was clicked. Probably it should do so.
306(defun alert-window (&key 
307                     (title "Alert")
308                     (message "Something happened.")
309                     (default-button "Okay")
310                     alternate-button
311                     other-button)
312  (let ((nstitle (%make-nsstring title))
313        (nsmessage (%make-nsstring message))
314        (ns-default-button (%make-nsstring default-button))
315        (ns-alternate-button (or (and alternate-button (%make-nsstring alternate-button))
316                                 +null-ptr+))
317        (ns-other-button (or (and other-button (%make-nsstring other-button))
318                             +null-ptr+)))
319    (#_NSRunAlertPanel nstitle nsmessage ns-default-button ns-alternate-button ns-other-button)
320    (#/release nstitle)
321    (#/release nsmessage)
322    (#/release ns-default-button)
323    (unless (eql ns-alternate-button +null-ptr+)
324      (#/release ns-alternate-button))
325    (unless (eql ns-other-button +null-ptr+)
326      (#/release ns-other-button))))
327
328;;; -----------------------------------------------------------------
329;;; utility to display a Cocoa progress window
330;;; -----------------------------------------------------------------
331
332(defparameter *progress-window-controller* nil)
333
334(defclass progress-window-controller (ns:ns-window-controller)
335    ((progress-window :foreign-type :id :reader progress-window)
336     (message-field :foreign-type :id :reader progress-window-message-field)
337     (progress-bar :foreign-type :id :reader progress-window-progress-bar))
338  (:metaclass ns:+ns-object))
339
340(defun get-progress-window ()
341  (unless *progress-window-controller*
342    (setf *progress-window-controller* 
343          (make-instance 'progress-window-controller))
344    (#/initWithWindowNibName: *progress-window-controller* #@"ProgressWindow"))
345  (unless (#/isWindowLoaded *progress-window-controller*)
346    (#/loadWindow *progress-window-controller*))
347  (let ((window (progress-window *progress-window-controller*)))
348    (if (or (null window)
349            (%null-ptr-p window))
350        nil
351        window)))
352
353(defmacro with-modal-progress-dialog (title message &body body)
354  `(let* ((nstitle (%make-nsstring ,title))
355          (nsmessage (%make-nsstring ,message))
356          (window (get-progress-window))
357          (progress-bar (progress-window-progress-bar *progress-window-controller*))
358          (message-field (progress-window-message-field *progress-window-controller*)))
359     (unwind-protect 
360          (if window
361              (progn
362                (#/setTitle: window nstitle)
363                (#/setIndeterminate: progress-bar #$YES)
364                (#/setUsesThreadedAnimation: progress-bar #$YES)
365                (#/setStringValue: message-field nsmessage)
366                (#/makeKeyAndOrderFront: window +null-ptr+)
367                (let ((modal-session (#/beginModalSessionForWindow: ccl::*nsapp* window)))
368                  (#/startAnimation: progress-bar +null-ptr+)
369                  (let ((result (progn ,@body)))
370                    (#/stopAnimation: progress-bar +null-ptr+)
371                    (#/orderOut: window +null-ptr+)
372                    (#/endModalSession: ccl::*nsapp* modal-session)
373                    result)))
374              (progn
375                (alert-window :title "Failure"
376                            :message "Unable to load the modal progress window")
377                nil))
378       (#/release nstitle)
379       (#/release nsmessage))))
380
381(defun post-tiger-p ()
382  (rlet ((p :int))
383    (#_Gestalt #$gestaltSystemVersion p)
384    (>= (%get-long p) #x1050)))
385
386
Note: See TracBrowser for help on using the repository browser.