source: trunk/source/cocoa-ide/cocoa-listener.lisp @ 12124

Last change on this file since 12124 was 12124, checked in by gb, 11 years ago

Use document name to remember all listener window positions (not
just the first listener to have been created.) Note that this
scheme is not compatible with the scheme used last week; the
initial listener's position will default to the system default
the first time the IDE is run after this update.

When a listener is restored to a saved position, setup cascading
relative to that position.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.4 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
6
7(def-cocoa-default *listener-input-font* :font #'(lambda ()
8                                                   (#/fontWithName:size:
9                                                    ns:ns-font
10                                                    #@"Monaco" 10.0))
11                   "Default font for listener input")
12(def-cocoa-default *listener-output-font* :font #'(lambda ()
13                                                    (#/fontWithName:size:
14                                                     ns:ns-font
15                                                     #@"Monaco" 10.0))
16                   "Default font for listener output")
17
18(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
19(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters")
20
21(def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output")
22
23(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output")
24
25(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color")
26
27(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
28
29(defun hemlock-ext:read-only-listener-p ()
30  *read-only-listener*)
31
32
33(defclass cocoa-listener-input-stream (fundamental-character-input-stream)
34  ((queue :initform ())
35   (queue-lock :initform (make-lock))
36   (read-lock :initform (make-lock))
37   (queue-semaphore :initform (make-semaphore)) ;; total queue count
38   (text-semaphore :initform (make-semaphore))  ;; text-only queue count
39   (cur-string :initform nil)
40   (cur-string-pos :initform 0)
41   (cur-env :initform nil)
42   (cur-sstream :initform nil)))
43
44
45
46(defmethod dequeue-listener-char ((stream cocoa-listener-input-stream) wait-p)
47  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
48    (with-lock-grabbed (read-lock)
49      (or (with-lock-grabbed (queue-lock)
50            (when (< cur-string-pos (length cur-string))
51              (prog1 (aref cur-string cur-string-pos) (incf cur-string-pos))))
52          (loop
53            (unless (if wait-p
54                      (wait-on-semaphore text-semaphore nil "Listener Input")
55                      (timed-wait-on-semaphore text-semaphore 0))
56              (return nil))
57            (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!")
58            (with-lock-grabbed (queue-lock)
59              (let* ((s (find-if #'stringp queue)))
60                (assert s () "queue/semaphore mismatch!")
61                (setq queue (delq s queue 1))
62                (when (< 0 (length s))
63                  (setf cur-string s cur-string-pos 1)
64                  (return (aref s 0))))))))))
65
66(defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) eof-value)
67  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream cur-env) stream
68    (with-lock-grabbed (read-lock)
69      (loop
70        (when cur-sstream
71          #+debug (log-debug "About to recursively read from sstring in env: ~s" cur-env)
72          (let* ((env cur-env)
73                 (form (progv (car env) (cdr env)
74                         (ccl::read-toplevel-form cur-sstream eof-value)))
75                 (last-form-in-selection (not (listen cur-sstream))))
76            #+debug (log-debug " --> ~s" form)
77            (when last-form-in-selection
78              (setf cur-sstream nil cur-env nil))
79            (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*)))))
80        (when (with-lock-grabbed (queue-lock)
81                (loop
82                  unless (< cur-string-pos (length cur-string)) return nil
83                  unless (whitespacep (aref cur-string cur-string-pos)) return t
84                  do (incf cur-string-pos)))
85          (return (values (call-next-method) nil t)))
86        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
87        (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
88          (cond ((stringp val)
89                 (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
90                 (setq cur-string val cur-string-pos 0))
91                (t
92                 (destructuring-bind (string package-name pathname) val
93                   (let ((env (cons '(*loading-file-source-file* *loading-toplevel-location*)
94                                    (list pathname nil))))
95                     (when package-name
96                       (push '*package* (car env))
97                       (push (ccl::pkg-arg package-name) (cdr env)))
98                     (setf cur-sstream (make-string-input-stream string) cur-env env))))))))))
99
100(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname)
101  (with-slots (queue-lock queue queue-semaphore) stream
102    (with-lock-grabbed (queue-lock)
103      (setq queue (nconc queue (list (list string package-name pathname))))
104      (signal-semaphore queue-semaphore))))
105
106(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string)
107  (with-slots (queue-lock queue queue-semaphore text-semaphore) stream
108    (with-lock-grabbed (queue-lock)
109      (setq queue (nconc queue (list string)))
110      (signal-semaphore queue-semaphore)
111      (signal-semaphore text-semaphore))))
112
113(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream))
114  (dequeue-listener-char stream nil))
115
116(defmethod stream-read-char ((stream cocoa-listener-input-stream))
117  (dequeue-listener-char stream t))
118
119(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char)
120  ;; Can't guarantee the right order of reads/unreads, just make sure not to
121  ;; introduce any internal inconsistencies (and dtrt for the non-conflict case).
122  (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
123    (with-lock-grabbed (queue-lock)
124      (cond ((>= cur-string-pos (length cur-string))
125             (push (string char) queue)
126             (signal-semaphore queue-semaphore)
127             (signal-semaphore text-semaphore))
128            ((< 0 cur-string-pos)
129             (decf cur-string-pos)
130             (setf (aref cur-string cur-string-pos) char))
131            (t (setf cur-string (concatenate 'string (string char) cur-string)))))))
132
133(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream))
134  t)
135
136(defmethod stream-clear-input ((stream cocoa-listener-input-stream))
137  (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream
138    (with-lock-grabbed (queue-lock)
139      (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil))))
140
141(defparameter $listener-flush-limit 100)
142
143(defclass cocoa-listener-output-stream (fundamental-character-output-stream)
144  ((lock :initform (make-lock))
145   (hemlock-view :initarg :hemlock-view)
146   (data :initform (make-array (1+ $listener-flush-limit)
147                               :adjustable t :fill-pointer 0
148                               :element-type 'character))))
149
150(defmethod stream-element-type ((stream cocoa-listener-output-stream))
151  (with-slots (data) stream
152    (array-element-type data)))
153
154(defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char)
155  (with-slots (data lock) stream
156    (when (with-lock-grabbed (lock)
157            (>= (vector-push-extend char data) $listener-flush-limit))
158      (stream-force-output stream))))
159
160;; This isn't really thread safe, but it's not too bad...  I'll take a chance - trying
161;; to get it to execute in the gui thread is too deadlock-prone.
162(defmethod hemlock-listener-output-mark-column ((view hi::hemlock-view))
163  (let* ((output-region (hi::variable-value 'hemlock::current-output-font-region
164                                            :buffer (hi::hemlock-view-buffer view))))
165    (hi::mark-charpos (hi::region-end output-region))))
166
167;; TODO: doesn't do the right thing for embedded tabs (in buffer or data)
168(defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream))
169  (with-slots (hemlock-view data lock) stream
170    (with-lock-grabbed (lock)
171      (let* ((n (length data))
172             (pos (position #\Newline data :from-end t)))
173        (if (null pos)
174          (+ (hemlock-listener-output-mark-column hemlock-view) n)
175          (- n pos 1))))))
176
177(defmethod ccl:stream-fresh-line  ((stream cocoa-listener-output-stream))
178  (with-slots (hemlock-view data lock) stream
179    (when (with-lock-grabbed (lock)
180            (let ((n (length data)))
181              (unless (if (= n 0)
182                        (= (hemlock-listener-output-mark-column hemlock-view) 0)
183                        (eq (aref data (1- n)) #\Newline))
184                (>= (vector-push-extend #\Newline data) $listener-flush-limit))))
185      (stream-force-output stream))))
186
187(defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream))
188  (stream-force-output stream))
189
190(defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream))
191  (if (typep *current-process* 'appkit-process)
192    (with-slots (hemlock-view data lock) stream
193      (with-lock-grabbed (lock)
194        (when (> (fill-pointer data) 0)
195          (append-output hemlock-view data)
196          (setf (fill-pointer data) 0))))
197    (with-slots (data) stream
198      (when (> (fill-pointer data) 0)
199        (queue-for-gui #'(lambda () (stream-force-output stream)))))))
200
201(defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream))
202  (with-slots (data lock) stream
203    (with-lock-grabbed (lock)
204      (setf (fill-pointer data) 0))))
205
206(defmethod ccl:stream-line-length ((stream cocoa-listener-output-stream))
207  ;; TODO: ** compute length from window size **
208  80)
209
210
211(defloadvar *cocoa-listener-count* 0)
212
213(defclass cocoa-listener-process (process)
214    ((input-stream :reader cocoa-listener-process-input-stream)
215     (output-stream :reader cocoa-listener-process-output-stream)
216     (backtrace-contexts :initform nil
217                         :accessor cocoa-listener-process-backtrace-contexts)
218     (window :reader cocoa-listener-process-window)))
219 
220(defloadvar *first-listener* t)
221
222(defun new-cocoa-listener-process (procname window)
223  (declare (special *standalone-cocoa-ide*))
224  (let* ((input-stream (make-instance 'cocoa-listener-input-stream))
225         (output-stream (make-instance 'cocoa-listener-output-stream
226                          :hemlock-view (hemlock-view window)))
227         
228         (proc
229          (ccl::make-mcl-listener-process 
230           procname
231           input-stream
232           output-stream
233           ;; cleanup function
234           #'(lambda ()
235               (mapcar #'(lambda (buf)
236                           (when (eq (buffer-process buf) *current-process*)
237                             (let ((doc (hi::buffer-document buf)))
238                               (when doc
239                                 (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it.
240                                 (#/performSelectorOnMainThread:withObject:waitUntilDone:
241                                  doc
242                                  (@selector #/close)
243                                  +null-ptr+
244                                  nil)))))
245                       hi:*buffer-list*))
246           :initial-function
247           #'(lambda ()
248               (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
249               (when (and *standalone-cocoa-ide*
250                        (prog1 *first-listener* (setq *first-listener* nil)))
251                 (ccl::startup-ccl (ccl::application-init-file ccl::*application*))
252                 (ui-object-note-package *nsapp* *package*))
253               (ccl::listener-function))
254           :echoing nil
255           :class 'cocoa-listener-process)))
256    (setf (slot-value proc 'input-stream) input-stream)
257    (setf (slot-value proc 'output-stream) output-stream)
258    (setf (slot-value proc 'window) window)
259    proc))
260 
261(defclass hemlock-listener-frame (hemlock-frame)
262    ()
263  (:metaclass ns:+ns-object))
264(declaim (special hemlock-listener-frame))
265
266
267(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
268    ()
269  (:metaclass ns:+ns-object)
270  )
271(declaim (special hemlock-listener-window-controller))
272
273;;; Listener documents are never (or always) ediited.  Don't cause their
274;;; close boxes to be highlighted.
275(objc:defmethod (#/setDocumentEdited: :void)
276    ((self hemlock-listener-window-controller) (edited :<BOOL>))
277  (declare (ignorable edited)))
278
279
280
281(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
282  (let* ((doc (#/document self)))
283    (if (or (%null-ptr-p doc)
284            (not (%null-ptr-p (#/fileURL doc))))
285      (call-next-method name)
286      (let* ((buffer (hemlock-buffer doc))
287             (bufname (if buffer (hi::buffer-name buffer))))
288        (if bufname
289          (%make-nsstring bufname)
290          (call-next-method name))))))
291
292
293;;; The HemlockListenerDocument class.
294
295
296(defclass hemlock-listener-document (hemlock-editor-document)
297  ((process :reader %hemlock-document-process :writer (setf hemlock-document-process)))
298  (:metaclass ns:+ns-object))
299(declaim (special hemlock-listener-document))
300
301(defgeneric hemlock-document-process (doc)
302  (:method ((unknown t)) nil)
303  (:method ((doc hemlock-listener-document)) (%hemlock-document-process doc)))
304
305;; Nowadays this is nil except for listeners.
306(defun buffer-process (buffer)
307  (hemlock-document-process (hi::buffer-document buffer)))
308
309(defmethod update-buffer-package ((doc hemlock-listener-document) buffer)
310  (declare (ignore buffer)))
311
312(defmethod document-encoding-name ((doc hemlock-listener-document))
313  "UTF-8")
314
315(defmethod user-input-style ((doc hemlock-listener-document))
316  hi::*listener-input-style*)
317 
318(defmethod textview-background-color ((doc hemlock-listener-document))
319  *listener-background-color*)
320
321;; For use with the :process-info listener modeline field
322(defmethod hemlock-ext:buffer-process-description (buffer)
323  (let ((proc (buffer-process buffer)))
324    (when proc
325      (format nil "~a(~d) [~a]"
326              (ccl:process-name proc)
327              (ccl::process-serial-number proc)
328              ;; TODO: this doesn't really work as a modeline item, because the modeline
329              ;; doesn't get notified when it changes.
330              (ccl:process-whostate proc)))))
331
332(objc:defmethod #/topListener ((self +hemlock-listener-document))
333  (let* ((all-documents (#/orderedDocuments *NSApp*)))
334    (dotimes (i (#/count all-documents) +null-ptr+)
335      (let* ((doc (#/objectAtIndex: all-documents i)))
336        (when (eql (#/class doc) self)
337          (return doc))))))
338
339(defun symbol-value-in-top-listener-process (symbol)
340  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
341     (if process
342       (ignore-errors (symbol-value-in-process symbol process))
343       (values nil t))))
344 
345(defun hemlock-ext:top-listener-output-stream ()
346  (let* ((process (hemlock-document-process (#/topListener hemlock-listener-document))))
347    (when process
348      (setq process (require-type process 'cocoa-listener-process))
349      (cocoa-listener-process-output-stream process))))
350
351
352
353(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
354  nil)
355
356
357
358(objc:defmethod #/init ((self hemlock-listener-document))
359  (let* ((doc (call-next-method)))
360    (unless (%null-ptr-p doc)
361      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
362                              "Listener"
363                              (format nil
364                                      "Listener-~d" *cocoa-listener-count*)))
365             (buffer (hemlock-buffer doc)))
366        (setf (hi::buffer-pathname buffer) nil
367              (hi::buffer-minor-mode buffer "Listener") t
368              (hi::buffer-name buffer) listener-name)
369        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
370    doc))
371
372(def-cocoa-default *initial-listener-x-pos* :float -100.0f0 "X position of upper-left corner of initial listener")
373
374(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener")
375
376(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
377(defloadvar *next-listener-y-pos* nil) ; likewise
378
379(objc:defmethod (#/close :void) ((self hemlock-listener-document))
380  (if (zerop (decf *cocoa-listener-count*))
381    (setq *next-listener-x-pos* nil
382          *next-listener-y-pos* nil))
383  (let* ((p (shiftf (hemlock-document-process self) nil)))
384    (when p
385      (process-kill p)))
386  (call-next-method))
387
388
389
390(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
391  (let* ((textstorage (slot-value self 'textstorage))
392         (window (%hemlock-frame-for-textstorage
393                  hemlock-listener-frame
394                  textstorage
395                  *listener-columns*
396                  *listener-rows*
397                  t
398                  (textview-background-color self)
399                  (user-input-style self)))
400         (listener-styles (#/arrayWithObjects: ns:ns-mutable-array
401                                               (rme-create-text-attributes
402                                                :font *listener-input-font*)
403                                               (rme-create-text-attributes
404                                                :font *listener-output-font*)
405                                               +null-ptr+))
406         (controller (make-instance
407                      'hemlock-listener-window-controller
408                      :with-window window))
409         (listener-name (hi::buffer-name (hemlock-buffer self)))
410         (path (#/windowTitleForDocumentDisplayName: controller (#/displayName self ))))
411    (with-slots (styles) textstorage
412      ;; We probably should be more disciplined about
413      ;; Cocoa memory management.  Having retain/release in
414      ;; random places all over the code is going to get
415      ;; unwieldy.
416      (#/release styles)
417      (setf styles (#/retain listener-styles)))
418    ;; Disabling background layout on listeners is an attempt to work
419    ;; around a bug.  The bug's probably gone ...
420    (let* ((layout-managers (#/layoutManagers textstorage)))
421      (dotimes (i (#/count layout-managers))
422        (let* ((layout (#/objectAtIndex: layout-managers i)))
423          (#/setBackgroundLayoutEnabled: layout nil))))
424    (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) self)
425    (#/setShouldCascadeWindows: controller nil)
426    (#/addWindowController: self controller)
427    (#/release controller)
428    (when path
429      (unless (#/setFrameAutosaveName: window path)
430        (setq path nil)))
431    (unless (and path
432                 (when (#/setFrameUsingName: window path)
433                   (let* ((frame (#/frame window)))
434                     (ns:with-ns-point (current-point
435                                        (ns:ns-rect-x frame)
436                                        (+ (ns:ns-rect-y frame)
437                                           (ns:ns-rect-height frame)))
438                        (let* ((next-point (#/cascadeTopLeftFromPoint:
439                                            window
440                                            current-point)))
441                     (setq *next-listener-x-pos*
442                           (ns:ns-point-x next-point)
443                           *next-listener-y-pos*
444                           (ns:ns-point-y next-point)))))
445                   t))
446      (ns:with-ns-point (current-point
447                         (or *next-listener-x-pos*
448                             (x-pos-for-window window *initial-listener-x-pos*))
449                         (or *next-listener-y-pos*
450                             (y-pos-for-window window *initial-listener-y-pos*)))
451        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
452          (setf *next-listener-x-pos* (ns:ns-point-x new-point)
453                *next-listener-y-pos* (ns:ns-point-y new-point)))))
454    (setf (hemlock-document-process self)
455          (new-cocoa-listener-process listener-name window))
456    controller))
457
458(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
459    ((self hemlock-listener-document)
460     tv
461     (range :<NSR>ange)
462     string)
463  (declare (ignore tv string))
464  (let* ((range-start (ns:ns-range-location range))
465         (range-end (+ range-start (ns:ns-range-length range)))
466         (buffer (hemlock-buffer self))
467         (protected-region (hi::buffer-protected-region buffer)))
468    (if protected-region
469      (let* ((prot-start (hi:mark-absolute-position (hi::region-start protected-region)))
470             (prot-end (hi:mark-absolute-position (hi::region-end protected-region))))
471        (not (or (and (>= range-start prot-start)
472                      (< range-start prot-end))
473                 (and (>= range-end prot-start)
474                      (< range-end prot-end)))))
475      t)))
476   
477   
478;;; Action methods
479(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
480  (declare (ignore sender))
481  (let* ((process (hemlock-document-process self)))
482    (when process
483      (ccl::force-break-in-listener process))))
484
485
486
487(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
488  (declare (ignore sender))
489  (let* ((process (hemlock-document-process self)))
490    #+debug (log-debug  "~&exitBreak process ~s" process)
491    (when process
492      (process-interrupt process #'abort-break))))
493
494(defmethod listener-backtrace-context ((proc cocoa-listener-process))
495  (car (cocoa-listener-process-backtrace-contexts proc)))
496
497(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
498  (let* ((process (hemlock-document-process self)))
499    (when process
500      (let* ((context (listener-backtrace-context process)))
501        (when context
502          (#/showWindow: (backtrace-controller-for-context context) sender))))))
503
504(defun restarts-controller-for-context (context)
505  (or (car (ccl::bt.restarts context))
506      (setf (car (ccl::bt.restarts context))
507            (let* ((tcr (ccl::bt.tcr context))
508                   (tsp-range (inspector::make-tsp-stack-range tcr context))
509                   (vsp-range (inspector::make-vsp-stack-range tcr context))
510                   (csp-range (inspector::make-csp-stack-range tcr context))
511                   (process (context-process context)))
512              (make-instance 'sequence-window-controller
513                             :sequence (cdr (ccl::bt.restarts context))
514                             :result-callback #'(lambda (r)
515                                                  (process-interrupt
516                                                   process
517                                                   #'invoke-restart-interactively
518                                                   r))
519                             :display #'(lambda (item stream)
520                                          (let* ((ccl::*aux-vsp-ranges* vsp-range)
521                                                 (ccl::*aux-tsp-ranges* tsp-range)
522                                                 (ccl::*aux-csp-ranges* csp-range))
523                                          (princ item stream)))
524                             :title (format nil "Restarts for ~a(~d), break level ~d"
525                                            (process-name process)
526                                            (process-serial-number process)
527                                            (ccl::bt.break-level context)))))))
528                           
529(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
530  (let* ((process (hemlock-document-process self)))
531    (when process
532      (let* ((context (listener-backtrace-context process)))
533        (when context
534          (#/showWindow: (restarts-controller-for-context context) sender))))))
535
536(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
537  (declare (ignore sender))
538  (let* ((process (hemlock-document-process self)))
539    (when process
540      (let* ((context (listener-backtrace-context process)))
541        (when context
542          (process-interrupt process #'invoke-restart-interactively 'continue))))))
543
544
545
546
547
548
549;;; Menu item action validation.  It'd be nice if we could distribute this a
550;;; bit better, so that this method didn't have to change whenever a new
551;;; action was implemented in this class.  For now, we have to do so.
552
553(defmethod document-validate-menu-item ((doc hemlock-listener-document) item)
554  ;; Return two values: the first is true if the second is definitive.
555  ;; So far, all actions demand that there be an underlying process, so
556  ;; check for that first.
557  (let* ((process (hemlock-document-process doc)))
558    (if process
559      (let* ((action (#/action item)))
560        (cond
561          ((or (eql action (@selector #/revertDocumentToSaved:))
562               (eql action (@selector #/saveDocument:))
563               (eql action (@selector #/saveDocumentAs:)))
564           (values t nil))
565          ((eql action (@selector #/interrupt:)) (values t t))
566          ((eql action (@selector #/continue:))
567           (let* ((context (listener-backtrace-context process)))
568             (values
569              t
570              (and context
571                   (find 'continue (cdr (ccl::bt.restarts context))
572                         :key #'restart-name)))))
573          ((or (eql action (@selector #/backtrace:))
574               (eql action (@selector #/exitBreak:))
575               (eql action (@selector #/restarts:)))
576           (values t
577                   (not (null (listener-backtrace-context process)))))))
578      (values nil nil))))
579
580(objc:defmethod (#/validateMenuItem: :<BOOL>)
581    ((self hemlock-listener-document) item)
582  (multiple-value-bind (have-opinion opinion)
583      (document-validate-menu-item self item)
584    (if have-opinion
585      opinion
586      (call-next-method item))))
587
588(defun shortest-package-name (package)
589  (let* ((name (package-name package))
590         (len (length name)))
591    (dolist (nick (package-nicknames package) name)
592      (let* ((nicklen (length nick)))
593        (if (< nicklen len)
594          (setq name nick len nicklen))))))
595
596(defmethod ui-object-note-package ((app ns:ns-application) package)
597  (let ((proc *current-process*)
598        (name (shortest-package-name package)))
599    (execute-in-gui #'(lambda ()
600                        (dolist (buf hi::*buffer-list*)
601                          (when (eq proc (buffer-process buf))
602                            (setf (hi::variable-value 'hemlock::current-package :buffer buf) name)))))))
603
604
605(defmethod eval-in-listener-process ((process cocoa-listener-process)
606                                     string &key path package)
607  (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string
608                         :package-name package :pathname path))
609
610;;; This is basically used to provide INPUT to the listener process, by
611;;; writing to an fd which is connected to that process's standard
612;;; input.
613(defun hemlock-ext:send-string-to-listener (listener-buffer string)
614  (let* ((process (buffer-process listener-buffer)))
615    (unless process
616      (error "No listener process found for ~s" listener-buffer))
617    (enqueue-listener-input (cocoa-listener-process-input-stream process) string)))
618
619
620
621(defun hemlock::evaluate-input-selection (selection)
622  (ccl::application-ui-operation *application* :eval-selection selection))
623 
624(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
625                                                    selection)
626  (declare (ignore selection))
627  (#/performSelectorOnMainThread:withObject:waitUntilDone:
628   (#/delegate *NSApp*)
629   (@selector #/ensureListener:)
630   +null-ptr+
631   #$YES)
632  (hemlock-document-process (#/topListener hemlock-listener-document)))
633
634(defmethod ui-object-eval-selection ((app ns:ns-application)
635                                     selection)
636  (let* ((target-listener (ui-object-choose-listener-for-selection
637                           app selection)))
638    (when target-listener
639      (destructuring-bind (package path string) selection
640        (eval-in-listener-process target-listener string :package package :path path)))))
641
642(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
643  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
644    (when target-listener
645      (destructuring-bind (package path) selection
646        (let ((string (format nil "(load ~S)" path)))
647          (eval-in-listener-process target-listener string :package package :path path))))))
648
649(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
650  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
651    (when target-listener
652      (destructuring-bind (package path) selection
653        (let ((string (format nil "(compile-file ~S)" path)))
654          (eval-in-listener-process target-listener string :package package :path path))))))
655
656(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
657  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
658    (when target-listener
659      (destructuring-bind (package path) selection
660        (let ((string (format nil "(progn (compile-file ~S)(load ~S))" 
661                              path
662                              (make-pathname :directory (pathname-directory path)
663                                             :name (pathname-name path)
664                                             :type (pathname-type path)))))
665          (eval-in-listener-process target-listener string :package package :path path))))))
666
667       
668 
Note: See TracBrowser for help on using the repository browser.