Context Navigation

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

Visit:

Last change on this file since 14895 was 14895, checked in by gb, 9 years ago
revert last change
File size: 18.1 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	;;
162
163	(defvar log-callback-errors :backtrace)
164
165	(defun maybe-log-callback-error (condition)
166	(when log-callback-errors
167	;; Put these in separate ignore-errors, so at least some of it can get thru
168	(let ((emsg (ignore-errors (princ-to-string condition))))
169	(ignore-errors (clear-output debug-io))
170	(ignore-errors (format debug-io "~&Lisp error: ~s" (or emsg condition)))
171	(when (eq log-callback-errors :backtrace)
172	(let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
173	(when err
174	(ignore-errors (format debug-io "~&Error printing call history - "))
175	(ignore-errors (print err debug-io))
176	(ignore-errors (princ err debug-io))
177	(ignore-errors (force-output debug-io))))))))
178
179	(defmacro with-callback-context (description &body body)
180	(let ((saved-debug-io (gensym)))
181	`(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
182	(let ((,saved-debug-io debug-io))
183	(handler-bind ((error #'(lambda (condition)
184	(let ((debug-io ,saved-debug-io))
185	(maybe-log-callback-error condition)
186	(abort)))))
187	,@body)))))
188
189	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
190	;;
191	;; utilities for executing in the cocoa event thread
192
193	(defstatic cocoa-thread-arg-id-map (make-id-map))
194
195	;; This is for debugging, it's preserved across queue-for-gui and bound
196	;; so it can be seen in backtraces.
197	(defvar invoking-event-context "unknown")
198	(defvar invoking-event-process nil)
199
200	(defun register-cocoa-thread-function (thunk result-handler context)
201	(assign-id-map-id cocoa-thread-arg-id-map (list* thunk
202	result-handler
203	(or context invoking-event-context)
204	current-process)))
205
206	(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
207	(invoke-lisp-function self id))
208
209	(defmethod invoke-lisp-function ((self ns:ns-application) id)
210	(destructuring-bind (thunk result-handler context . invoking-process)
211	(id-map-free-object cocoa-thread-arg-id-map (if (numberp id) id (#/longValue id)))
212	(handle-invoking-lisp-function thunk result-handler context invoking-process)))
213
214	(defun execute-in-gui (thunk &key context)
215	"Execute thunk in the main cocoa thread, return whatever values it returns"
216	(if (typep current-process 'appkit-process)
217	(handle-invoking-lisp-function thunk nil context)
218	(if (or (not nsapp) (not (#/isRunning nsapp)))
219	(error "cocoa thread not available")
220	(with-autorelease-pool
221	(let* ((return-values nil)
222	(result-handler #'(lambda (&rest values) (setq return-values values)))
223	(arg (make-instance 'ns:ns-number
224	:with-long (register-cocoa-thread-function thunk result-handler context))))
225	(#/performSelectorOnMainThread:withObject:waitUntilDone:
226	nsapp
227	(@selector #/invokeLispFunction:)
228	arg
229	t)
230	(#/release arg)
231	(apply #'values return-values))))))
232
233
234	(defconstant $lisp-function-event-subtype 17)
235
236	(defclass lisp-application (ns:ns-application)
237	((termp :foreign-type :<BOOL>)
238	(console :foreign-type :id :accessor console))
239	(:metaclass ns:+ns-object))
240
241	(defmethod current-event-modifier-p (modifier-mask)
242	(let* ((event (#/currentEvent nsapp))
243	(modifiers (#/modifierFlags event)))
244	(logtest modifier-mask modifiers)))
245
246	(defun current-event-command-key-p ()
247	(current-event-modifier-p #$NSCommandKeyMask))
248
249	;;; I'm not sure if there's another way to recognize events whose
250	;;; type is #$NSApplicationDefined.
251	(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
252	(declare (dynamic-extent self e))
253	(if (and (eql (#/type e) #$NSApplicationDefined)
254	(eql (#/subtype e) $lisp-function-event-subtype))
255	(invoke-lisp-function self (#/data1 e))
256	(call-next-method e)))
257
258	;; This queues an event rather than just doing performSelectorOnMainThread, so that the
259	;; action is deferred until the event thread is idle.
260	(defun queue-for-gui (thunk &key result-handler context at-start)
261	"Queue thunk for execution in main cocoa thread and return immediately."
262	(execute-in-gui
263	#'(lambda ()
264	(let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
265	ns:ns-event
266	#$NSApplicationDefined
267	(ns:make-ns-point 0 0)
268	0
269	0.0d0
270	0
271	+null-ptr+
272	$lisp-function-event-subtype
273	(register-cocoa-thread-function thunk result-handler context)
274	0)))
275	;(#/retain e)
276	(#/postEvent:atStart: nsapp e (not (null at-start)))))))
277
278	(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process current-process))
279	;; TODO: the point is to execute result-handler in the original process, but this will do for now.
280	(let* ((invoking-event-process invoking-process)
281	(invoking-event-context context))
282	(if result-handler
283	(multiple-value-call result-handler (funcall thunk))
284	(funcall thunk))))
285
286	(defun choose-directory-dialog ()
287	(execute-in-gui #'(lambda ()
288	(let ((op (#/openPanel ns:ns-open-panel)))
289	(#/setAllowsMultipleSelection: op nil)
290	(#/setCanChooseDirectories: op t)
291	(#/setCanChooseFiles: op nil)
292	(when (eql (#/runModalForTypes: op +null-ptr+) #$NSOKButton)
293	;; #/stringByStandardizingPath seems to strip trailing slashes
294	(let* ((path (#/retain (#/stringByAppendingString:
295	(#/stringByStandardizingPath
296	(#/objectAtIndex: (#/filenames op) 0))
297	#@"/"))))
298	path))))))
299
300
301	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302	;;
303	;; debugging
304
305	(defun double-%-in (string)
306	;; Replace any % characters in string with %%, to keep them from
307	;; being treated as printf directives.
308	(let* ((%pos (position #\% string)))
309	(if %pos
310	(concatenate 'string (subseq string 0 %pos) "%%" (double-%-in (subseq string (1+ %pos))))
311	string)))
312
313	(defun log-debug (format-string &rest args)
314	(let ((string (apply #'format nil format-string args)))
315	(#_NSLog (ccl::%make-nsstring (double-%-in string)))))
316
317	(pushnew '(log-debug . 0) ccl::format-arg-functions :test #'equal)
318
319	(defun nslog-condition (c &optional (msg "Error in event loop: "))
320	(let* ((rep (format nil "~a" c)))
321	(with-cstrs ((str rep)
322	(msg-str msg))
323	(with-nsstr (nsstr str (length rep))
324	(with-nsstr (nsmsg msg-str (length msg))
325	(#_NSLog #@"%@: %@" :address nsmsg :address nsstr))))))
326
327	(defun nsstring-for-lisp-condition (cond)
328	(%make-nsstring (double-%-in (or (ignore-errors (princ-to-string cond))
329	"#<error printing error message>"))))
330
331
332
333	(defun assume-cocoa-thread ()
334	(assert (eq current-process ccl::initial-process)))
335
336	(defmethod assume-not-editing ((whatever t)))
337
338	;;; -----------------------------------------------------------------
339	;;; utility to display a Cocoa alert window
340	;;; -----------------------------------------------------------------
341	;;; TODO: Currently this form gives no indication which button was clicked. Probably it should do so.
342	(defun alert-window (&key
343	(title "Alert")
344	(message "Something happened.")
345	(default-button "Okay")
346	alternate-button
347	other-button)
348	(let ((nstitle (%make-nsstring title))
349	(nsmessage (%make-nsstring message))
350	(ns-default-button (%make-nsstring default-button))
351	(ns-alternate-button (or (and alternate-button (%make-nsstring alternate-button))
352	+null-ptr+))
353	(ns-other-button (or (and other-button (%make-nsstring other-button))
354	+null-ptr+)))
355	(#_NSRunAlertPanel nstitle nsmessage ns-default-button ns-alternate-button ns-other-button)
356	(#/release nstitle)
357	(#/release nsmessage)
358	(#/release ns-default-button)
359	(unless (eql ns-alternate-button +null-ptr+)
360	(#/release ns-alternate-button))
361	(unless (eql ns-other-button +null-ptr+)
362	(#/release ns-other-button))))
363
364	;;; -----------------------------------------------------------------
365	;;; utility to display a Cocoa progress window
366	;;; -----------------------------------------------------------------
367
368	(defparameter progress-window-controller nil)
369
370	(defclass progress-window-controller (ns:ns-window-controller)
371	((progress-window :foreign-type :id :reader progress-window)
372	(message-field :foreign-type :id :reader progress-window-message-field)
373	(progress-bar :foreign-type :id :reader progress-window-progress-bar))
374	(:metaclass ns:+ns-object))
375
376	(defun get-progress-window ()
377	(unless progress-window-controller
378	(setf progress-window-controller
379	(make-instance 'progress-window-controller))
380	(#/initWithWindowNibName: progress-window-controller #@"ProgressWindow"))
381	(unless (#/isWindowLoaded progress-window-controller)
382	(#/loadWindow progress-window-controller))
383	(let ((window (progress-window progress-window-controller)))
384	(if (or (null window)
385	(%null-ptr-p window))
386	nil
387	window)))
388
389	(defmacro with-modal-progress-dialog (title message &body body)
390	`(let* ((nstitle (%make-nsstring ,title))
391	(nsmessage (%make-nsstring ,message))
392	(window (get-progress-window))
393	(progress-bar (progress-window-progress-bar progress-window-controller))
394	(message-field (progress-window-message-field progress-window-controller)))
395	(unwind-protect
396	(if window
397	(progn
398	(#/setTitle: window nstitle)
399	(#/setIndeterminate: progress-bar #$YES)
400	(#/setUsesThreadedAnimation: progress-bar #$YES)
401	(#/setStringValue: message-field nsmessage)
402	(#/makeKeyAndOrderFront: window +null-ptr+)
403	(let ((modal-session (#/beginModalSessionForWindow: ccl::nsapp window)))
404	(#/startAnimation: progress-bar +null-ptr+)
405	(let ((result (progn ,@body)))
406	(#/stopAnimation: progress-bar +null-ptr+)
407	(#/orderOut: window +null-ptr+)
408	(#/endModalSession: ccl::nsapp modal-session)
409	result)))
410	(progn
411	(alert-window :title "Failure"
412	:message "Unable to load the modal progress window")
413	nil))
414	(#/release nstitle)
415	(#/release nsmessage))))
416
417	(defun post-tiger-p ()
418	#+cocotron t
419	#-cocotron
420	(rlet ((p :int))
421	(#_Gestalt #$gestaltSystemVersion p)
422	(>= (%get-long p) #x1050)))
423
424
425	;; This works even if an event loop is not running.
426
427	#+windows-target
428	(defun shift-key-now-p ()
429	(logbitp 15 (#_GetAsyncKeyState #$VK_SHIFT)))
430
431	#+darwin-target
432	(defun shift-key-now-p ()
433	(let* ((event (#_CGEventCreate +null-ptr+))
434	(flags (#_CGEventGetFlags event)))
435	(prog1
436	(logtest flags #$kCGEventFlagMaskShift)
437	(#_CFRelease event))))
438
439	;;; I would remove this, but I think that people use it...
440
441	(defclass abstract-ns-lisp-string (ns:ns-string)
442	()
443	(:metaclass ns:+ns-object))
444
445	(defgeneric ns-lisp-string-string (abstract-ns-lisp-string)
446	(:method ((self abstract-ns-lisp-string)) nil))
447
448	(objc:defmethod (#/length :<NSUI>nteger) ((self abstract-ns-lisp-string))
449	(length (ns-lisp-string-string self)))
450
451	(objc:defmethod (#/characterAtIndex: :unichar) ((self abstract-ns-lisp-string) (index :<NSUI>nteger))
452	(char-code (char (ns-lisp-string-string self) index)))
453
454	(defclass ns-lisp-string (abstract-ns-lisp-string)
455	((lisp-string :initarg :string :reader ns-lisp-string-string))
456	(:metaclass ns:+ns-object))

Note: See TracBrowser for help on using the repository browser.

Download in other formats: