source: branches/event-ide/ccl/cocoa-ide/cocoa-utils.lisp @ 7911

Last change on this file since 7911 was 7911, checked in by gz, 13 years ago

make cl:ed return the view created
fixes for edit-definition breakage
fixes for clicking/recentering breakage
fixes for process-file-options breakage
swap name/nickname for hi/hemlock-internals, for less verbose output.
more massaging of callback context, error handling.

File size: 9.8 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 alpha)
105  (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color
106                                              (cgfloat red)
107                                              (cgfloat green)
108                                              (cgfloat blue)
109                                              (cgfloat alpha)))
110
111(defun windows ()
112  (let* ((win-arr (#/orderedWindows *NSApp*))
113         (ret nil))
114    (dotimes (i (#/count win-arr))
115      (push (#/objectAtIndex: win-arr i) ret))
116    (nreverse ret)))
117
118
119;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
120;;
121
122(defvar *log-callback-errors* :backtrace)
123
124(defun maybe-log-callback-error (condition)
125  (when *log-callback-errors*
126    ;; Put these in separate ignore-errors, so at least some of it can get thru
127    (let ((emsg (ignore-errors (princ-to-string condition))))
128      (ignore-errors (clear-output *debug-io*))
129      (ignore-errors (format *debug-io* "~&Lisp error: ~s" (or emsg condition)))
130      (when (eq *log-callback-errors* :backtrace)
131        (let* ((err (nth-value 1 (ignore-errors (ccl:print-call-history :detailed-p t)))))
132          (when err
133            (ignore-errors (format *debug-io* "~&Error printing call history - "))
134            (ignore-errors (print err *debug-io*))
135            (ignore-errors (princ err *debug-io*))
136            (ignore-errors (force-output *debug-io*))))))))
137
138(defmacro with-callback-context (description &body body)
139  (let ((saved-debug-io (gensym)))
140    `(ccl::with-standard-abort-handling ,(format nil "Abort ~a" description)
141       (let ((,saved-debug-io *debug-io*))
142         (handler-bind ((error #'(lambda (condition)
143                                   (let ((*debug-io* ,saved-debug-io))
144                                     (maybe-log-callback-error condition)
145                                     (abort)))))
146           ,@body)))))
147
148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149;;
150;; utilities for executing in the cocoa event thread
151
152(defstatic *cocoa-thread-arg-id-map* (make-id-map))
153
154;; This is for debugging, it's preserved across queue-for-gui and bound
155;; so it can be seen in backtraces.
156(defvar *invoking-event-context* "unknown")
157(defvar *invoking-event-process* nil)
158
159(defun register-cocoa-thread-function (thunk result-handler context)
160  (assign-id-map-id *cocoa-thread-arg-id-map* (list* thunk
161                                                     result-handler
162                                                     (or context *invoking-event-context*)
163                                                     *current-process*)))
164
165(objc:defmethod (#/invokeLispFunction: :void) ((self ns:ns-application) id)
166  (invoke-lisp-function self id))
167
168(defmethod invoke-lisp-function ((self ns:ns-application) id)
169  (destructuring-bind (thunk result-handler context . invoking-process)
170                      (id-map-free-object *cocoa-thread-arg-id-map* (if (numberp id) id (#/longValue id)))
171    (handle-invoking-lisp-function thunk result-handler context invoking-process)))
172
173(defun execute-in-gui (thunk &key context)
174  "Execute thunk in the main cocoa thread, return whatever values it returns"
175  (if (typep *current-process* 'appkit-process)
176    (handle-invoking-lisp-function thunk nil context)
177    (if (or (not *nsapp*) (not (#/isRunning *nsapp*)))
178      (error "cocoa thread not available")
179      (let* ((return-values nil)
180             (result-handler #'(lambda (&rest values) (setq return-values values)))
181             (arg (make-instance 'ns:ns-number
182                    :with-long (register-cocoa-thread-function thunk result-handler context))))
183        (#/performSelectorOnMainThread:withObject:waitUntilDone:
184         *nsapp*
185         (@selector #/invokeLispFunction:)
186         arg
187         t)
188        (apply #'values return-values)))))
189
190
191(defconstant $lisp-function-event-subtype 17)
192
193(defclass lisp-application (ns:ns-application)
194    ((termp :foreign-type :<BOOL>))
195  (:metaclass ns:+ns-object))
196
197;;; I'm not sure if there's another way to recognize events whose
198;;; type is #$NSApplicationDefined.
199(objc:defmethod (#/sendEvent: :void) ((self lisp-application) e)
200  (if (and (eql (#/type e) #$NSApplicationDefined)
201           (eql (#/subtype e) $lisp-function-event-subtype))
202    (invoke-lisp-function self (#/data1 e))
203    (call-next-method e)))
204
205;; This queues an event rather than just doing performSelectorOnMainThread, so that the
206;; action is deferred until the event thread is idle.
207(defun queue-for-gui (thunk &key result-handler context at-start)
208  "Queue thunk for execution in main cocoa thread and return immediately."
209  (execute-in-gui
210   #'(lambda () 
211       (let* ((e (#/otherEventWithType:location:modifierFlags:timestamp:windowNumber:context:subtype:data1:data2:
212                  ns:ns-event
213                  #$NSApplicationDefined
214                  (ns:make-ns-point 0 0)
215                  0
216                  0.0d0
217                  0
218                  +null-ptr+
219                  $lisp-function-event-subtype
220                  (register-cocoa-thread-function thunk result-handler context)
221                  0)))
222         ;(#/retain e)
223         (#/postEvent:atStart: *nsapp* e (not (null at-start)))))))
224
225(defun handle-invoking-lisp-function (thunk result-handler context &optional (invoking-process *current-process*))
226  ;; TODO: the point is to execute result-handler in the original process, but this will do for now.
227  (let* ((*invoking-event-process* invoking-process)
228         (*invoking-event-context* context))
229    (if result-handler
230      (multiple-value-call result-handler (funcall thunk))
231      (funcall thunk))))
232
233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
234;;
235;; debugging
236
237(defun log-debug (format-string &rest args)
238  (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args))))
239
240(defun nslog-condition (c)
241  (let* ((rep (format nil "~a" c)))
242    (with-cstrs ((str rep))
243      (with-nsstr (nsstr str (length rep))
244        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
245
246
247
248(defun assume-cocoa-thread ()
249  (assert (eq *current-process* ccl::*initial-process*)))
250
251(defmethod assume-not-editing ((whatever t)))
252
Note: See TracBrowser for help on using the repository browser.