source: release/1.8/source/cocoa-ide/cocoa-utils.lisp @ 15284

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

Restarts window fix from trunk.

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