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

Last change on this file since 14894 was 14894, checked in by gb, 9 years ago

nuke command-line args when loading, or try to

File size: 18.4 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  (let* ((table-view (slot-value self 'table-view))
76         (title (slot-value self 'title)))
77    (unless (%null-ptr-p table-view)
78      (setf (slot-value self 'table-view) (%null-ptr))
79      (#/release table-view))
80    (unless (%null-ptr-p title)
81      (setf (slot-value self 'title) (%null-ptr))
82      (#/release title))
83    (objc:remove-lisp-slots self)
84    (call-next-method)))
85
86(objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller)
87                                            notification)
88  (declare (ignore notification))
89  (#/setDataSource: (slot-value self 'table-view) +null-ptr+)
90  (#/autorelease self))
91
92(objc:defmethod (#/sequenceDoubleClick: :void)
93    ((self sequence-window-controller) sender)
94  (let* ((n (#/selectedRow sender)))
95    (when (>= n 0)
96      (with-slots (sequence result-callback) self
97        (funcall result-callback (elt sequence n))))))
98
99(objc:defmethod (#/numberOfRowsInTableView: :<NSI>nteger)
100    ((self sequence-window-controller) view)
101  (declare (ignore view))
102  (length (slot-value self 'sequence)))
103
104
105(objc:defmethod #/tableView:objectValueForTableColumn:row:
106    ((self sequence-window-controller) view column (row :<NSI>nteger))
107  (declare (ignore column view))
108  (with-slots (display sequence) self
109    (#/autorelease
110     (%make-nsstring (with-output-to-string (s)
111                       (funcall display (elt sequence row) s))))))
112
113(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys)
114  (let* ((window (#/window self)))
115    (with-slots (title) self
116      (when title (#/setTitle: window (%make-nsstring title))))
117    (#/reloadData (sequence-window-controller-table-view self))
118    (#/performSelectorOnMainThread:withObject:waitUntilDone:
119     self
120     (@selector #/showWindow:)
121     +null-ptr+
122     nil)))
123
124;;; Looks like a "util" to me ...
125(defun pathname-to-url (pathname)
126  (make-instance 'ns:ns-url
127                 :file-url-with-path
128                 (%make-nsstring (native-translated-namestring pathname))))
129
130(defun cgfloat (number)
131  (float number ccl::+cgfloat-zero+))
132
133(defun color-values-to-nscolor (red green blue &optional alpha)
134  (#/retain (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
135                                                       (cgfloat red)
136                                                       (cgfloat green)
137                                                       (cgfloat blue)
138                                                       (cgfloat (or alpha 1.0)))))
139
140(defun map-windows (fn)
141  (let ((win-arr (#/orderedWindows *NSApp*)))
142    (dotimes (i (#/count win-arr))
143      (funcall fn (#/objectAtIndex: win-arr i)))))
144
145(defun windows ()
146  (let* ((ret nil))
147    (map-windows #'(lambda (w) (push w ret)))
148    (nreverse ret)))
149
150(defun front-window ()
151  (map-windows #'(lambda (win) (return-from front-window win))))
152
153(defun target ()
154  "Returns the second window in the list returned by (windows)."
155  (let ((first? nil))
156    (map-windows #'(lambda (win)
157                     (if first?
158                       (return-from target win)
159                       (setf first? t))))))
160
161(defun first-window-satisfying-predicate (pred)
162  (block foo
163    (map-windows #'(lambda (w) (when (funcall pred w)
164                                 (return-from foo w)))))) 
165
166(defun first-window-with-controller-type (controller-type)
167  (first-window-satisfying-predicate #'(lambda (w) (typep (#/windowController w) controller-type))))
168
169;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
170;;
171
172(defvar *log-callback-errors* :backtrace)
173
174(defun maybe-log-callback-error (condition)
175  (when *log-callback-errors*
176    ;; Put these in separate ignore-errors, so at least some of it can get thru
177    (let ((emsg (ignore-errors (princ-to-string condition))))
178      (ignore-errors (clear-output *debug-io*))
179      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
180      (when (eq *log-callback-errors* :backtrace)
181        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
182          (when err
183            (ignore-errors (format *debug-io* "~&Error printing call history - "))
184            (ignore-errors (print err *debug-io*))
185            (ignore-errors (princ err *debug-io*))
186            (ignore-errors (force-output *debug-io*))))))))
187
188(defmacro with-callback-context (description &body body)
189  (let ((saved-debug-io (gensym)))
190    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
191       (let ((,saved-debug-io *debug-io*))
192         (handler-bind ((error #'(lambda (condition)
193                                   (let ((*debug-io* ,saved-debug-io))
194                                     (maybe-log-callback-error condition)
195                                     (abort)))))
196           ,@body)))))
197
198;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
199;;
200;; utilities for executing in the cocoa event thread
201
202(defstatic *cocoa-thread-arg-id-map* (make-id-map))
203
204;; This is for debugging, it's preserved across queue-for-gui and bound
205;; so it can be seen in backtraces.
206(defvar *invoking-event-context* "unknown")
207(defvar *invoking-event-process* nil)
208
209(defun register-cocoa-thread-function (thunk result-handler context)
210  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
211                                                     result-handler
212                                                     (or context *invoking-event-context*)
213                                                     *current-process*)))
214
215(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
216  (invoke-lisp-function self id))
217
218(defmethod invoke-lisp-function ((self ns:ns-application) id)
219  (destructuring-bind (thunk result-handler context . invoking-process)
220                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
221    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
222
223(defun execute-in-gui (thunk &key context)
224  "Execute thunk in the main cocoa thread, return whatever values it returns"
225  (if (typep *current-process* 'appkit-process)
226    (handle-invoking-lisp-function thunk nil context)
227    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
228      (error "cocoa thread not available")
229      (with-autorelease-pool 
230          (let* ((return-values nil)
231                 (result-handler #'(lambda (&rest values) (setq return-values values)))
232                 (arg (make-instance 'ns:ns-number
233                                     :with-long (register-cocoa-thread-function thunk result-handler context))))
234            (#/performSelectorOnMainThread:withObject:waitUntilDone:
235             *nsapp*
236             (@selector #/invokeLispFunction:)
237             arg
238             t)
239            (#/release arg)
240            (apply #'values return-values))))))
241
242
243(defconstant $lisp-function-event-subtype 17)
244
245(defclass lisp-application (ns:ns-application)
246    ((termp :foreign-type :<BOOL>)
247     (console :foreign-type :id :accessor console))
248  (:metaclass ns:+ns-object))
249
250(defmethod current-event-modifier-p (modifier-mask)
251  (let* ((event (#/currentEvent *nsapp*))
252         (modifiers (#/modifierFlags event)))
253    (logtest modifier-mask modifiers)))
254
255(defun current-event-command-key-p ()
256  (current-event-modifier-p #$NSCommandKeyMask))
257
258;;; I'm not sure if there's another way to recognize events whose
259;;; type is #$NSApplicationDefined.
260(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
261  (declare (dynamic-extent self e))
262  (if (and (eql (#/type e) #$NSApplicationDefined)
263           (eql (#/subtype e) $lisp-function-event-subtype))
264    (invoke-lisp-function self (#/data1 e))
265    (call-next-method e)))
266
267;; This queues an event rather than just doing performSelectorOnMainThread, so that the
268;; action is deferred until the event thread is idle.
269(defun queue-for-gui (thunk &key result-handler context at-start)
270  "Queue thunk for execution in main cocoa thread and return immediately."
271  (execute-in-gui
272   #'(lambda () 
273       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
274                  ns:ns-event
275                  #$NSApplicationDefined
276                  (ns:make-ns-point 0 0)
277                  0
278                  0.0d0
279                  0
280                  +null-ptr+
281                  $lisp-function-event-subtype
282                  (register-cocoa-thread-function thunk result-handler context)
283                  0)))
284         ;(#/retain e)
285         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
286
287(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
288  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
289  (let* ((*invoking-event-process* invoking-process)
290         (*invoking-event-context* context))
291    (if result-handler
292      (multiple-value-call result-handler (funcall thunk))
293      (funcall thunk))))
294
295(defun choose-directory-dialog ()
296  (execute-in-gui #'(lambda ()
297                      (let ((op (#/openPanel ns:ns-open-panel)))
298                        (#/setAllowsMultipleSelection: op nil)
299                        (#/setCanChooseDirectories: op t)
300                        (#/setCanChooseFiles: op nil)
301                        (when (eql (#/runModalForTypes: op +null-ptr+) #$NSOKButton)
302                          ;; #/stringByStandardizingPath seems to strip trailing slashes
303                         (let* ((path (#/retain (#/stringByAppendingString:
304                                        (#/stringByStandardizingPath
305                                         (#/objectAtIndex: (#/filenames op) 0))
306                                        #@"/"))))
307                            path))))))
308
309
310;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
311;;
312;; debugging
313
314(defun double-%-in (string)
315  ;; Replace any % characters in string with %%, to keep them from
316  ;; being treated as printf directives.
317  (let* ((%pos (position #\% string)))
318    (if %pos
319      (concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos))))
320      string)))
321
322(defun log-debug (format-string &rest args)
323  (let ((string (apply #'format nil format-string args)))
324    (#_NSLog (ccl::%make-nsstring (double-%-in string)))))
325
326(pushnew '(log-debug . 0) ccl::*format-arg-functions* :test #'equal)
327
328(defun nslog-condition (c &optional (msg "Error in event loop: "))
329  (let* ((rep (format nil "~a" c)))
330    (with-cstrs ((str rep)
331                 (msg-str msg))
332      (with-nsstr (nsstr str (length rep))
333        (with-nsstr (nsmsg msg-str (length msg))
334         (#_NSLog #@"%@: %@" :address nsmsg :address nsstr))))))
335
336(defun nsstring-for-lisp-condition (cond)
337  (%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
338                                   "#<error printing error message>"))))
339
340
341
342(defun assume-cocoa-thread ()
343  (assert (eq *current-process* ccl::*initial-process*)))
344
345(defmethod assume-not-editing ((whatever t)))
346
347;;; -----------------------------------------------------------------
348;;; utility to display a Cocoa alert window
349;;; -----------------------------------------------------------------
350;;; TODO: Currently this form gives no indication which button was clicked. Probably it should do so.
351(defun alert-window (&key 
352                     (title "Alert")
353                     (message "Something happened.")
354                     (default-button "Okay")
355                     alternate-button
356                     other-button)
357  (let ((nstitle (%make-nsstring title))
358        (nsmessage (%make-nsstring message))
359        (ns-default-button (%make-nsstring default-button))
360        (ns-alternate-button (or (and alternate-button (%make-nsstring alternate-button))
361                                 +null-ptr+))
362        (ns-other-button (or (and other-button (%make-nsstring other-button))
363                             +null-ptr+)))
364    (#_NSRunAlertPanel nstitle nsmessage ns-default-button ns-alternate-button ns-other-button)
365    (#/release nstitle)
366    (#/release nsmessage)
367    (#/release ns-default-button)
368    (unless (eql ns-alternate-button +null-ptr+)
369      (#/release ns-alternate-button))
370    (unless (eql ns-other-button +null-ptr+)
371      (#/release ns-other-button))))
372
373;;; -----------------------------------------------------------------
374;;; utility to display a Cocoa progress window
375;;; -----------------------------------------------------------------
376
377(defparameter *progress-window-controller* nil)
378
379(defclass progress-window-controller (ns:ns-window-controller)
380    ((progress-window :foreign-type :id :reader progress-window)
381     (message-field :foreign-type :id :reader progress-window-message-field)
382     (progress-bar :foreign-type :id :reader progress-window-progress-bar))
383  (:metaclass ns:+ns-object))
384
385(defun get-progress-window ()
386  (unless *progress-window-controller*
387    (setf *progress-window-controller* 
388          (make-instance 'progress-window-controller))
389    (#/initWithWindowNibName: *progress-window-controller* #@"ProgressWindow"))
390  (unless (#/isWindowLoaded *progress-window-controller*)
391    (#/loadWindow *progress-window-controller*))
392  (let ((window (progress-window *progress-window-controller*)))
393    (if (or (null window)
394            (%null-ptr-p window))
395        nil
396        window)))
397
398(defmacro with-modal-progress-dialog (title message &body body)
399  `(let* ((nstitle (%make-nsstring ,title))
400          (nsmessage (%make-nsstring ,message))
401          (window (get-progress-window))
402          (progress-bar (progress-window-progress-bar *progress-window-controller*))
403          (message-field (progress-window-message-field *progress-window-controller*)))
404     (unwind-protect 
405          (if window
406              (progn
407                (#/setTitle: window nstitle)
408                (#/setIndeterminate: progress-bar #$YES)
409                (#/setUsesThreadedAnimation: progress-bar #$YES)
410                (#/setStringValue: message-field nsmessage)
411                (#/makeKeyAndOrderFront: window +null-ptr+)
412                (let ((modal-session (#/beginModalSessionForWindow: ccl::*nsapp* window)))
413                  (#/startAnimation: progress-bar +null-ptr+)
414                  (let ((result (progn ,@body)))
415                    (#/stopAnimation: progress-bar +null-ptr+)
416                    (#/orderOut: window +null-ptr+)
417                    (#/endModalSession: ccl::*nsapp* modal-session)
418                    result)))
419              (progn
420                (alert-window :title "Failure"
421                            :message "Unable to load the modal progress window")
422                nil))
423       (#/release nstitle)
424       (#/release nsmessage))))
425
426(defun post-tiger-p ()
427  #+cocotron t
428  #-cocotron 
429  (rlet ((p :int))
430    (#_Gestalt #$gestaltSystemVersion p)
431    (>= (%get-long p) #x1050)))
432
433
434;; This works even if an event loop is not running.
435
436#+windows-target
437(defun shift-key-now-p ()
438  (logbitp 15 (#_GetAsyncKeyState #$VK_SHIFT)))
439
440#+darwin-target
441(defun shift-key-now-p ()
442  (let* ((event (#_CGEventCreate +null-ptr+))
443         (flags (#_CGEventGetFlags event)))
444    (prog1
445        (logtest flags #$kCGEventFlagMaskShift)
446      (#_CFRelease event))))
447
448;;; I would remove this, but I think that people use it...
449
450(defclass abstract-ns-lisp-string (ns:ns-string)
451    ()
452  (:metaclass ns:+ns-object))
453
454(defgeneric ns-lisp-string-string (abstract-ns-lisp-string)
455  (:method ((self abstract-ns-lisp-string)) nil))
456
457(objc:defmethod (#/length :<NSUI>nteger) ((self abstract-ns-lisp-string))
458    (length (ns-lisp-string-string self)))
459
460(objc:defmethod (#/characterAtIndex: :unichar) ((self abstract-ns-lisp-string) (index :<NSUI>nteger))
461  (char-code (char (ns-lisp-string-string self) index)))
462
463(defclass ns-lisp-string (abstract-ns-lisp-string)
464  ((lisp-string :initarg :string :reader ns-lisp-string-string))
465  (:metaclass ns:+ns-object))
Note: See TracBrowser for help on using the repository browser.