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

Last change on this file since 15201 was 15201, checked in by rme, 7 years ago

Implement execute-for-gui in a slightly different way.

Instead of performSelectorOnMainThread:withObject:waitUntilDone:,
we always enqueue a user-defined event which tells the event
loop to call a designated lisp function. We do the process
synchronization in lisp rather than relying on whatever Cocoa
uses internally.

File size: 19.6 KB
Line 
1; -*- Mode: Lisp; Package: GUI -*-
2
3(in-package "GUI")
4
5(defmethod list-from-ns-array (thing) (error "~S is not an instance of NS:NS-ARRAY" thing))
6(defmethod list-from-ns-array ((nsa ns:ns-array))
7  (let ((result (list))
8        (c (#/count nsa)))
9    (dotimes (i c) (setf result (push (#/objectAtIndex: nsa i) result)))
10    (reverse result)))
11
12(defclass key-select-table-view (ns:ns-table-view)
13  ()
14  (:metaclass ns:+ns-object))
15
16(objc:defmethod (#/keyDown: :void) ((self key-select-table-view) event)
17  (let* ((code (#/keyCode event)))
18    (if (and (>= (#/selectedRow self) 0)
19             (= code 36)) ; return key
20      (#/sendAction:to:from: *NSApp* (#/doubleAction self) (#/target self) self)
21      (call-next-method event))))
22
23(defclass sequence-window-controller (ns:ns-window-controller)
24    ((table-view :foreign-type :id :reader sequence-window-controller-table-view)
25     (sequence :initform nil :initarg :sequence :type sequence :reader sequence-window-controller-sequence)
26     (result-callback :initarg :result-callback)
27     (display :initform #'(lambda (item stream) (prin1 item stream)) :initarg :display)
28     (title :initform "Sequence dialog" :initarg :title))
29  (:metaclass ns:+ns-object))
30
31
32(objc:defmethod #/init ((self sequence-window-controller))
33  (call-next-method)
34  (let* ((w (new-cocoa-window :activate nil))
35         (contentview (#/contentView w))
36         (contentframe (#/frame contentview))
37         (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe)))
38    (#/setWindow: self w)
39    (#/setDelegate: w self)
40    (#/setWindowController: w self)
41    (#/setHasVerticalScroller: scrollview t)
42    (#/setHasHorizontalScroller: scrollview t)
43    (#/setAutohidesScrollers: scrollview t)
44    (#/setRulersVisible: scrollview nil)
45    (#/setAutoresizingMask: scrollview (logior
46                                        #$NSViewWidthSizable
47                                        #$NSViewHeightSizable))
48    (#/setAutoresizesSubviews: (#/contentView scrollview) t)
49    (let* ((table-view (make-instance 'key-select-table-view)))
50      (#/setDocumentView: scrollview table-view)
51      (#/release table-view)
52      #-cocotron
53      (#/setColumnAutoresizingStyle: table-view #$NSTableViewUniformColumnAutoresizingStyle)
54      (setf (slot-value self 'table-view) table-view)
55      (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@"")))
56        (#/setEditable: column nil)
57        #-cocotron
58        (#/setResizingMask: column #$NSTableColumnAutoresizingMask)
59        (#/addTableColumn: table-view column)
60        (#/release column))
61      (#/setAutoresizingMask: table-view (logior
62                                          #$NSViewWidthSizable
63                                          #$NSViewHeightSizable))
64      (#/sizeToFit table-view)
65      (#/setDataSource: table-view self)
66      (#/setTarget: table-view self)
67      (#/setHeaderView: table-view +null-ptr+)
68      (#/setUsesAlternatingRowBackgroundColors: table-view t)
69      (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:))
70      (#/addSubview: contentview scrollview)
71      (#/release scrollview)
72      self)))
73
74(objc:defmethod (#/dealloc :void) ((self sequence-window-controller))
75  (call-next-method))
76
77(objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller)
78                                            notification)
79  (declare (ignore notification))
80  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
81  (#/autorelease self))
82
83(objc:defmethod (#/sequenceDoubleClick: :void)
84    ((self sequence-window-controller) sender)
85  (let* ((n (#/selectedRow sender)))
86    (when (>= n 0)
87      (with-slots (sequence result-callback) self
88        (funcall result-callback (elt sequence n))))))
89
90(objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger)
91    ((self sequence-window-controller) view)
92  (declare (ignore view))
93  (length (slot-value self 'sequence)))
94
95
96(objc:defmethod #/tableView:objectValueForTableColumn:row:
97    ((self sequence-window-controller) view column (row :<NSI>nteger))
98  (declare (ignore column view))
99  (with-slots (display sequence) self
100    (#/autorelease
101     (%make-nsstring (with-output-to-string (s)
102                       (funcall display (elt sequence row) s))))))
103
104(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys)
105  (let* ((window (#/window self)))
106    (with-slots (title) self
107      (when title (#/setTitle: window (%make-nsstring title))))
108    (#/reloadData (sequence-window-controller-table-view self))
109    (#/performSelectorOnMainThread:withObject:waitUntilDone:
110     self
111     (@selector #/showWindow:)
112     +null-ptr+
113     nil)))
114
115;;; Looks like a "util" to me ...
116(defun pathname-to-url (pathname)
117  (make-instance 'ns:ns-url
118                 :file-url-with-path
119                 (%make-nsstring (native-translated-namestring pathname))))
120
121(defun cgfloat (number)
122  (float number ccl::+cgfloat-zero+))
123
124(defun color-values-to-nscolor (red green blue &optional alpha)
125  (#/retain (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
126                                                       (cgfloat red)
127                                                       (cgfloat green)
128                                                       (cgfloat blue)
129                                                       (cgfloat (or alpha 1.0)))))
130
131(defun map-windows (fn)
132  (let ((win-arr (#/orderedWindows *NSApp*)))
133    (dotimes (i (#/count win-arr))
134      (funcall fn (#/objectAtIndex: win-arr i)))))
135
136(defun windows ()
137  (let* ((ret nil))
138    (map-windows #'(lambda (w) (push w ret)))
139    (nreverse ret)))
140
141(defun front-window ()
142  (map-windows #'(lambda (win) (return-from front-window win))))
143
144(defun target ()
145  "Returns the second window in the list returned by (windows)."
146  (let ((first? nil))
147    (map-windows #'(lambda (win)
148                     (if first?
149                       (return-from target win)
150                       (setf first? t))))))
151
152(defun first-window-satisfying-predicate (pred)
153  (block foo
154    (map-windows #'(lambda (w) (when (funcall pred w)
155                                 (return-from foo w)))))) 
156
157(defun first-window-with-controller-type (controller-type)
158  (first-window-satisfying-predicate #'(lambda (w) (typep (#/windowController w) controller-type))))
159
160
161(defun new-listener (&key (inhibit-greeting ccl::*inhibit-greeting*))
162  (let ((wptr (execute-in-gui (lambda ()
163                                (declare (special hemlock-listener-document))
164                                ;; TODO: fix this.
165                                (let ((old ccl::*inhibit-greeting*))
166                                  (unwind-protect
167                                      (progn
168                                        (setq ccl::*inhibit-greeting* inhibit-greeting)
169                                        (#/newListener: (#/delegate *NSApp*) (%null-ptr)))
170                                    (setq ccl::*inhibit-greeting* old)))
171                                (let ((doc (#/topListener hemlock-listener-document)))
172                                  (unless (%null-ptr-p doc)
173                                    (#/window (#/lastObject (#/windowControllers doc)))))))))
174    (when wptr (hemlock-view wptr))))
175
176(defun cocoa-close (object &optional wait-p)
177  (if (eq *current-process* ccl::*initial-process*)
178    (#/close object)
179    (#/performSelectorOnMainThread:withObject:waitUntilDone:
180     object
181     (@selector #/close)
182     +null-ptr+
183     wait-p)))
184
185;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186;;
187
188(defvar *log-callback-errors* :backtrace)
189
190(defun maybe-log-callback-error (condition)
191  (when *log-callback-errors*
192    ;; Put these in separate ignore-errors, so at least some of it can get thru
193    (let ((emsg (ignore-errors (princ-to-string condition))))
194      (ignore-errors (clear-output *debug-io*))
195      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
196      (when (eq *log-callback-errors* :backtrace)
197        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
198          (when err
199            (ignore-errors (format *debug-io* "~&Error printing call history - "))
200            (ignore-errors (print err *debug-io*))
201            (ignore-errors (princ err *debug-io*))
202            (ignore-errors (force-output *debug-io*))))))))
203
204(defmacro with-callback-context (description &body body)
205  (let ((saved-debug-io (gensym)))
206    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
207       (let ((,saved-debug-io *debug-io*))
208         (handler-bind ((error #'(lambda (condition)
209                                   (let ((*debug-io* ,saved-debug-io))
210                                     (maybe-log-callback-error condition)
211                                     (abort)))))
212           ,@body)))))
213
214
215;;; Usually, one does not sublass NSApplication.  We do it mainly
216;;; because we use a user-defined event to signal the event loop to
217;;; invoke a lisp function, and the only way I know of to respond to a
218;;; user-defined event is to override -[NSApplication sendEvent:].
219
220(defclass lisp-application (ns:ns-application)
221    ((termp :foreign-type :<BOOL>)
222     (console :foreign-type :id :accessor console))
223  (:metaclass ns:+ns-object))
224
225(defconstant $lisp-function-event-subtype 17)
226
227(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
228  (declare (dynamic-extent self e))
229  (if (and (eql (#/type e) #$NSApplicationDefined)
230           (eql (#/subtype e) $lisp-function-event-subtype))
231    (deregister-and-invoke-epf-id (#/data1 e))
232    (call-next-method e)))
233
234;;; Large parts of Cocoa are not thread safe.  Many calls must be made
235;;; only on the "main" (i.e., the initial) thread.  As mentioned
236;;; above, we use a user-defined event to provide a way for this to
237;;; happen.
238;;;
239;;; For historical reasons, CCL calls threads "processes".  So,
240;;; instead of speaking of the "main thread" or "event thread", we
241;;; will use the term "event process".  Note that in the following
242;;; functions, "epf" means "event process function".
243
244(defstatic *epf-id-map* (make-id-map))
245
246(defun register-epf (f)
247  (assign-id-map-id *epf-id-map* f))
248
249(defun deregister-and-invoke-epf-id (id)
250  (let ((f (id-map-free-object *epf-id-map* id)))
251    (funcall f)))
252
253(defun queue-for-event-process (f &key at-start)
254  "Place a special event on the event process's event queue that will
255cause the zero-argument function F to be invoked when the event is
256processed.  Any return values from F are ignored.  If AT-START is
257true, the event will be placed at the front of the event queue."
258  (if (and *nsapp* (#/isRunning *nsapp*))
259    ;; It's possible that the event loop will go away after we check,
260    ;; but in that case the application is probably in the process of
261    ;; exiting.
262    (let ((id (register-epf f)))
263      (rletz ((pt #>NSPoint))
264        (objc:with-autorelease-pool
265          (with-macptrs ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
266                             ns:ns-event
267                             #$NSApplicationDefined ;type
268                             pt                     ;location
269                             0                      ;modifierFlags
270                             0d0                    ;timestamp
271                             0                      ;windowNumber
272                             +null-ptr+             ;context
273                             $lisp-function-event-subtype ;subtype
274                             id                     ;data1
275                             0)))                   ;data2
276              ;; It's explicitly OK to do this from any thread.
277              (#/postEvent:atStart: *nsapp* e (if at-start #$YES #$NO))))))
278    (error "The event process does not seem to be running an event loop")))
279
280(defun epf-semaphore ()
281  (or (getf (process-plist *current-process*) :epf-semaphore)
282      (setf (getf (process-plist *current-process*) :epf-semaphore)
283            (make-semaphore))))
284
285(defun call-in-event-process (f)
286  "Arrange to invoke the zero-argument function F in the event
287process, and return whatever values F returns.  If called from the
288event process, invoke F immediately.  Otherwise, place a special event
289at the front of the event process's queue, and block until the event
290process has processed that event and invoked F."
291  (if (eq *current-process* ccl::*initial-process*)
292    (funcall f)
293    (let ((return-values nil)
294          (done (epf-semaphore)))
295      (flet ((epf-wrapper ()
296               (unwind-protect
297                    (setq return-values (multiple-value-list (funcall f)))
298                 (signal-semaphore done))))
299        (declare (dynamic-extent #'epf-wrapper)) ;careful with this
300        (queue-for-event-process #'epf-wrapper :at-start t)
301        (wait-on-semaphore done nil "epf semaphore wait")
302        (apply #'values return-values)))))
303
304;;; previously used names
305(defun execute-in-gui (thunk &key context)
306  (declare (ignore context))
307  (call-in-event-process thunk))
308
309(defun queue-for-gui (thunk &key result-handler context at-start)
310  (declare (ignore result-handler context))
311  (queue-for-event-process thunk :at-start at-start))
312
313
314(defmethod current-event-modifier-p (modifier-mask)
315  (let* ((event (#/currentEvent *nsapp*))
316         (modifiers (#/modifierFlags event)))
317    (logtest modifier-mask modifiers)))
318
319(defun current-event-command-key-p ()
320  (current-event-modifier-p #$NSCommandKeyMask))
321
322(defun choose-directory-dialog ()
323  (execute-in-gui #'(lambda ()
324                      (let ((op (#/openPanel ns:ns-open-panel)))
325                        (#/setAllowsMultipleSelection: op nil)
326                        (#/setCanChooseDirectories: op t)
327                        (#/setCanChooseFiles: op nil)
328                        (when (eql (#/runModalForTypes: op +null-ptr+) #$NSOKButton)
329                          ;; #/stringByStandardizingPath seems to strip trailing slashes
330                         (let* ((path (#/retain (#/stringByAppendingString:
331                                        (#/stringByStandardizingPath
332                                         (#/objectAtIndex: (#/filenames op) 0))
333                                        #@"/"))))
334                            path))))))
335
336
337;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
338;;
339;; debugging
340
341(defun double-%-in (string)
342  ;; Replace any % characters in string with %%, to keep them from
343  ;; being treated as printf directives.
344  (let* ((%pos (position #\% string)))
345    (if %pos
346      (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos))))
347      string)))
348
349(defun log-debug (format-string &rest args)
350  (let ((string (apply #'format nil format-string args)))
351    (#_NSLog (ccl::%make-nsstring (double-%-in string)))))
352
353(pushnew '(log-debug . 0) ccl::*format-arg-functions* :test #'equal)
354
355(defun nslog-condition (c &optional (msg "Error in event loop: "))
356  (let* ((rep (format nil "~a" c)))
357    (with-cstrs ((str rep)
358                 (msg-str msg))
359      (with-nsstr (nsstr str (length rep))
360        (with-nsstr (nsmsg msg-str (length msg))
361         (#_NSLog #@"%@: %@" :address nsmsg :address nsstr))))))
362
363(defun nsstring-for-lisp-condition (cond)
364  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
365                                   "#<error printing error message>"))))
366
367
368
369(defun assume-cocoa-thread ()
370  (assert (eq *current-process* ccl::*initial-process*)))
371
372(defmethod assume-not-editing ((whatever t)))
373
374;;; -----------------------------------------------------------------
375;;; utility to display a Cocoa alert window
376;;; -----------------------------------------------------------------
377;;; TODO: Currently this form gives no indication which button was clicked. Probably it should do so.
378(defun alert-window (&key 
379                     (title "Alert")
380                     (message "Something happened.")
381                     (default-button "Okay")
382                     alternate-button
383                     other-button)
384  (let ((nstitle (%make-nsstring title))
385        (nsmessage (%make-nsstring message))
386        (ns-default-button (%make-nsstring default-button))
387        (ns-alternate-button (or (and alternate-button (%make-nsstring alternate-button))
388                                 +null-ptr+))
389        (ns-other-button (or (and other-button (%make-nsstring other-button))
390                             +null-ptr+)))
391    (#_NSRunAlertPanel nstitle nsmessage ns-default-button ns-alternate-button ns-other-button)
392    (#/release nstitle)
393    (#/release nsmessage)
394    (#/release ns-default-button)
395    (unless (eql ns-alternate-button +null-ptr+)
396      (#/release ns-alternate-button))
397    (unless (eql ns-other-button +null-ptr+)
398      (#/release ns-other-button))))
399
400;;; -----------------------------------------------------------------
401;;; utility to display a Cocoa progress window
402;;; -----------------------------------------------------------------
403
404(defparameter *progress-window-controller* nil)
405
406(defclass progress-window-controller (ns:ns-window-controller)
407    ((progress-window :foreign-type :id :reader progress-window)
408     (message-field :foreign-type :id :reader progress-window-message-field)
409     (progress-bar :foreign-type :id :reader progress-window-progress-bar))
410  (:metaclass ns:+ns-object))
411
412(defun get-progress-window ()
413  (unless *progress-window-controller*
414    (setf *progress-window-controller* 
415          (make-instance 'progress-window-controller))
416    (#/initWithWindowNibName: *progress-window-controller* #@"ProgressWindow"))
417  (unless (#/isWindowLoaded *progress-window-controller*)
418    (#/loadWindow *progress-window-controller*))
419  (let ((window (progress-window *progress-window-controller*)))
420    (if (or (null window)
421            (%null-ptr-p window))
422        nil
423        window)))
424
425(defmacro with-modal-progress-dialog (title message &body body)
426  `(let* ((nstitle (%make-nsstring ,title))
427          (nsmessage (%make-nsstring ,message))
428          (window (get-progress-window))
429          (progress-bar (progress-window-progress-bar *progress-window-controller*))
430          (message-field (progress-window-message-field *progress-window-controller*)))
431     (unwind-protect 
432          (if window
433              (progn
434                (#/setTitle: window nstitle)
435                (#/setIndeterminate: progress-bar #$YES)
436                (#/setUsesThreadedAnimation: progress-bar #$YES)
437                (#/setStringValue: message-field nsmessage)
438                (#/makeKeyAndOrderFront: window +null-ptr+)
439                (let ((modal-session (#/beginModalSessionForWindow: ccl::*nsapp* window)))
440                  (#/startAnimation: progress-bar +null-ptr+)
441                  (let ((result (progn ,@body)))
442                    (#/stopAnimation: progress-bar +null-ptr+)
443                    (#/orderOut: window +null-ptr+)
444                    (#/endModalSession: ccl::*nsapp* modal-session)
445                    result)))
446              (progn
447                (alert-window :title "Failure"
448                            :message "Unable to load the modal progress window")
449                nil))
450       (#/release nstitle)
451       (#/release nsmessage))))
452
453(defun post-tiger-p ()
454  #+cocotron t
455  #-cocotron 
456  (rlet ((p :int))
457    (#_Gestalt #$gestaltSystemVersion p)
458    (>= (%get-long p) #x1050)))
459
460
461;; This works even if an event loop is not running.
462
463#+windows-target
464(defun shift-key-now-p ()
465  (logbitp 15 (#_GetAsyncKeyState #$VK_SHIFT)))
466
467#+darwin-target
468(defun shift-key-now-p ()
469  (let* ((event (#_CGEventCreate +null-ptr+))
470         (flags (#_CGEventGetFlags event)))
471    (prog1
472        (logtest flags #$kCGEventFlagMaskShift)
473      (#_CFRelease event))))
474
475;;; I would remove this, but I think that people use it...
476
477(defclass abstract-ns-lisp-string (ns:ns-string)
478    ()
479  (:metaclass ns:+ns-object))
480
481(defgeneric ns-lisp-string-string (abstract-ns-lisp-string)
482  (:method ((self abstract-ns-lisp-string)) nil))
483
484(objc:defmethod (#/length :<NSUI>nteger) ((self abstract-ns-lisp-string))
485    (length (ns-lisp-string-string self)))
486
487(objc:defmethod (#/characterAtIndex: :unichar) ((self abstract-ns-lisp-string) (index :<NSUI>nteger))
488  (char-code (char (ns-lisp-string-string self) index)))
489
490(defclass ns-lisp-string (abstract-ns-lisp-string)
491  ((lisp-string :initarg :string :reader ns-lisp-string-string))
492  (:metaclass ns:+ns-object))
Note: See TracBrowser for help on using the repository browser.