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

Last change on this file since 11805 was 11805, checked in by gz, 12 years ago

Make the compiler scan format strings for possible errors. ccl::*format-arg-functions* is the alist of functions that should be scanned (so setting this to nil is a way to disable the scanning). The code to actually do the scanning is in format.lisp. It doesn't seem to slow down the compiler in any noticable way. It finds some cases of insufficient args in format strings in ccl sources, I'll fix those in a separate checkin later.

File size: 15.5 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
Note: See TracBrowser for help on using the repository browser.