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

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

Ensure that the text selected via the find panel is selected by Hemlock.

Do this by setting the hemlock-text-view's delegate to the window
controller, and implementing the delegate method textViewDidChangeSelection:.
In that method, see if the NSTextView selection and the Hemlock seletion
differ, and synch them up if needed.

See ticket:1151.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 45.6 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                                                    #+darwin-target
11                                                    #@"Monaco"
12                                                    #-darwin-target
13                                                    #@"Courier New"
14                                                    (font-size-kludge 10.0)))
15                   "Default font for listener input")
16(def-cocoa-default *listener-output-font* :font #'(lambda ()
17                                                    (#/fontWithName:size:
18                                                     ns:ns-font
19                                                     #+darwin-target
20                                                     #@"Monaco"
21                                                     #-darwin-target
22                                                     #@"Courier New"
23                                                     (font-size-kludge 10.0)))
24                   "Default font for listener output")
25
26(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
27(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters")
28
29(def-cocoa-default hi::*listener-output-style* :int 1 "Text style index for listener output")
30
31(def-cocoa-default hi::*listener-input-style* :int 0 "Text style index for listener output")
32
33(def-cocoa-default *listener-background-color* :color '(1.0 1.0 1.0 1.0) "Listener default background color")
34
35(def-cocoa-default *read-only-listener* :bool t "Do not allow editing old listener output")
36
37(defun hemlock-ext:read-only-listener-p ()
38  *read-only-listener*)
39
40
41(defclass cocoa-listener-input-stream (fundamental-character-input-stream)
42  ((queue :initform ())
43   (queue-lock :initform (make-lock))
44   (read-lock :initform (make-lock))
45   (queue-semaphore :initform (make-semaphore)) ;; total queue count
46   (text-semaphore :initform (make-semaphore))  ;; text-only queue count
47   (cur-string :initform nil)
48   (cur-string-pos :initform 0)
49   (cur-env :initform nil)
50   (cur-sstream :initform nil)
51   (cur-offset :initform nil)
52   (source-map :initform nil)
53   (reading-line :initform nil :accessor hi:input-stream-reading-line)))
54
55(defmethod interactive-stream-p ((stream cocoa-listener-input-stream))
56  t)
57
58
59
60(defmethod queued-listener-char ((stream cocoa-listener-input-stream) wait-p dequeue-p)
61  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
62    (with-lock-grabbed (read-lock)
63      (or (with-lock-grabbed (queue-lock)
64            (when (< cur-string-pos (length cur-string))
65              (prog1 (aref cur-string cur-string-pos) (and dequeue-p (incf cur-string-pos)))))
66          (loop
67            (unless (if wait-p
68                      (wait-on-semaphore text-semaphore nil "Listener Input")
69                      (timed-wait-on-semaphore text-semaphore 0))
70              (return nil))
71            (assert (timed-wait-on-semaphore queue-semaphore 0) () "queue/text mismatch!")
72            (with-lock-grabbed (queue-lock)
73              (let* ((s (find-if #'stringp queue)))
74                (assert s () "queue/semaphore mismatch!")
75                (setq queue (delq s queue 1))
76                (when (< 0 (length s))
77                  (setf cur-string s cur-string-pos (if dequeue-p 1 0))
78                  (return (aref s 0))))))))))
79
80(defmethod ccl::read-toplevel-form ((stream cocoa-listener-input-stream) &key eof-value)
81  (with-slots (queue queue-lock read-lock queue-semaphore text-semaphore cur-string cur-string-pos cur-sstream
82               cur-env source-map cur-offset)
83    stream
84    (with-lock-grabbed (read-lock)
85      (loop
86        (when cur-sstream
87          #+debug (log-debug "About to recursively read from sstring in env: ~s" cur-env)
88          (let* ((env cur-env)
89                 (form (progv (car env) (cdr env)
90                         (ccl::read-toplevel-form cur-sstream
91                                                  :eof-value eof-value
92                                                  :file-name *loading-file-source-file*
93                                                  :start-offset cur-offset
94                                                  :map source-map)))
95                 (last-form-in-selection (not (listen cur-sstream))))
96            #+debug (log-debug " --> ~s" form)
97            (when last-form-in-selection
98              (setf cur-sstream nil cur-env nil))
99            (return (values form env (or last-form-in-selection ccl::*verbose-eval-selection*)))))
100        (when (with-lock-grabbed (queue-lock)
101                (loop
102                  unless (< cur-string-pos (length cur-string)) return nil
103                  unless (whitespacep (aref cur-string cur-string-pos)) return t
104                  do (incf cur-string-pos)))
105          (return (values (call-next-method) nil t)))
106        (wait-on-semaphore queue-semaphore nil "Toplevel Read")
107        (without-interrupts
108         (let ((val (with-lock-grabbed (queue-lock) (pop queue))))
109           (cond ((stringp val)
110                  (assert (timed-wait-on-semaphore text-semaphore 0) () "text/queue mismatch!")
111                  (setq cur-string val cur-string-pos 0))
112                 (val
113                  (destructuring-bind (string package-name pathname offset) val
114                    ;; This env is used both for read and eval.
115                    (let ((env (cons '(*loading-file-source-file* *load-pathname* *load-truename* *loading-toplevel-location*
116                                                                  ccl::*nx-source-note-map*)
117                                     (list pathname pathname (and pathname (or (probe-file pathname) pathname)) nil
118                                           source-map))))
119                      (when package-name
120                        (push '*package* (car env))
121                        (push (ccl::pkg-arg package-name) (cdr env)))
122                      (if source-map
123                        (clrhash source-map)
124                        (setf source-map (make-hash-table :test 'eq :shared nil)))
125                      (setf cur-sstream (make-string-input-stream string) cur-env env cur-offset offset)))))))))))
126
127(defmethod enqueue-toplevel-form ((stream cocoa-listener-input-stream) string &key package-name pathname offset)
128  (with-slots (queue-lock queue queue-semaphore) stream
129    (with-lock-grabbed (queue-lock)
130      (setq queue (nconc queue (list (list string package-name pathname offset))))
131      (signal-semaphore queue-semaphore))))
132
133(defmethod enqueue-listener-input ((stream cocoa-listener-input-stream) string)
134  (when (> (length string) 0)
135    (with-slots (queue-lock queue queue-semaphore text-semaphore) stream
136      (with-lock-grabbed (queue-lock)
137        (setq queue (nconc queue (list string)))
138        (signal-semaphore queue-semaphore)
139        (signal-semaphore text-semaphore)))))
140
141(defmethod stream-read-char-no-hang ((stream cocoa-listener-input-stream))
142  (queued-listener-char stream nil t))
143
144(defmethod stream-read-char ((stream cocoa-listener-input-stream))
145  (queued-listener-char stream t t))
146
147;; The default implementation of peek-char will lose the character if aborted. This won't.
148(defmethod stream-peek-char ((stream cocoa-listener-input-stream))
149  (queued-listener-char stream t nil))
150
151(defmethod stream-listen ((stream cocoa-listener-input-stream))
152  (queued-listener-char stream nil nil))
153
154(defmethod stream-unread-char ((stream cocoa-listener-input-stream) char)
155  ;; Can't guarantee the right order of reads/unreads, just make sure not to
156  ;; introduce any internal inconsistencies (and dtrt for the non-conflict case).
157  (with-slots (queue queue-lock queue-semaphore text-semaphore cur-string cur-string-pos) stream
158    (with-lock-grabbed (queue-lock)
159      (cond ((>= cur-string-pos (length cur-string))
160             (push (string char) queue)
161             (signal-semaphore queue-semaphore)
162             (signal-semaphore text-semaphore))
163            ((< 0 cur-string-pos)
164             (decf cur-string-pos)
165             (setf (aref cur-string cur-string-pos) char))
166            (t (setf cur-string (concatenate 'string (string char) cur-string)))))))
167
168(defmethod ccl::stream-eof-transient-p ((stream cocoa-listener-input-stream))
169  t)
170
171(defmethod stream-clear-input ((stream cocoa-listener-input-stream))
172  (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream
173    (with-lock-grabbed (queue-lock)
174      (setf (hi::input-stream-reading-line stream) nil)
175      (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil))))
176
177(defmethod stream-read-line ((stream cocoa-listener-input-stream))
178  (let* ((old-reading-line (hi:input-stream-reading-line stream)))
179    (unwind-protect
180         (progn
181           (setf (hi::input-stream-reading-line stream) t)
182           (call-next-method))
183      (setf (hi:input-stream-reading-line stream) old-reading-line))))
184
185(defparameter $listener-flush-limit 4095)
186
187(defclass cocoa-listener-output-stream (fundamental-character-output-stream)
188  ((lock :initform (make-lock))
189   (hemlock-view :initarg :hemlock-view)
190   (data :initform (make-array (1+ $listener-flush-limit)
191                               :adjustable t :fill-pointer 0
192                               :element-type 'character))
193   (limit :initform $listener-flush-limit)))
194
195(defmethod stream-element-type ((stream cocoa-listener-output-stream))
196  (with-slots (data) stream
197    (array-element-type data)))
198
199(defmethod ccl:stream-write-char ((stream cocoa-listener-output-stream) char)
200  (with-slots (data lock limit) stream
201    (when (with-lock-grabbed (lock)
202            (>= (vector-push-extend char data) limit))
203      (stream-force-output stream))))
204
205;; This isn't really thread safe, but it's not too bad...  I'll take a chance - trying
206;; to get it to execute in the gui thread is too deadlock-prone.
207(defmethod hemlock-listener-output-mark-column ((view hi::hemlock-view))
208  (let* ((output-region (hi::variable-value 'hemlock::current-output-font-region
209                                            :buffer (hi::hemlock-view-buffer view))))
210    (hi::mark-charpos (hi::region-end output-region))))
211
212;; TODO: doesn't do the right thing for embedded tabs (in buffer or data)
213(defmethod ccl:stream-line-column ((stream cocoa-listener-output-stream))
214  (with-slots (hemlock-view data lock) stream
215    (with-lock-grabbed (lock)
216      (let* ((n (length data))
217             (pos (position #\Newline data :from-end t)))
218        (if (null pos)
219          (+ (hemlock-listener-output-mark-column hemlock-view) n)
220          (- n pos 1))))))
221
222(defmethod ccl:stream-fresh-line  ((stream cocoa-listener-output-stream))
223  (with-slots (hemlock-view data lock limit) stream
224    (when (with-lock-grabbed (lock)
225            (let ((n (length data)))
226              (unless (if (= n 0)
227                        (= (hemlock-listener-output-mark-column hemlock-view) 0)
228                        (eq (aref data (1- n)) #\Newline))
229                (>= (vector-push-extend #\Newline data) limit))))
230      (stream-force-output stream))))
231
232(defmethod ccl::stream-finish-output ((stream cocoa-listener-output-stream))
233  (stream-force-output stream))
234
235(defmethod ccl:stream-force-output ((stream cocoa-listener-output-stream))
236  (if (typep *current-process* 'appkit-process)
237    (with-slots (hemlock-view data lock) stream
238      (with-lock-grabbed (lock)
239        (when (> (fill-pointer data) 0)
240          (append-output hemlock-view data)
241          (setf (fill-pointer data) 0))))
242    (with-slots (data) stream
243      (when (> (fill-pointer data) 0)
244        (queue-for-gui #'(lambda () (stream-force-output stream)))))))
245
246(defmethod ccl:stream-clear-output ((stream cocoa-listener-output-stream))
247  (with-slots (data lock) stream
248    (with-lock-grabbed (lock)
249      (setf (fill-pointer data) 0))))
250
251(defmethod ccl:stream-line-length ((stream cocoa-listener-output-stream))
252  (with-slots (hemlock-view) stream
253    (values (hemlock-view-size hemlock-view))))
254
255(defloadvar *cocoa-listener-count* 0)
256
257(defclass cocoa-listener-process (process)
258    ((input-stream :initarg :listener-input-stream :reader cocoa-listener-process-input-stream)
259     (output-stream :initarg :listener-output-stream :reader cocoa-listener-process-output-stream)
260     (backtrace-contexts :initform nil
261                         :accessor cocoa-listener-process-backtrace-contexts)
262     (window :initarg :listener-window :initform nil :reader cocoa-listener-process-window)))
263 
264(defloadvar *first-listener* t)
265
266(defun new-cocoa-listener-process (procname window &key (class 'cocoa-listener-process)
267                                                        (initial-function 'ccl::listener-function)
268                                                        initargs)
269  (declare (special *standalone-cocoa-ide*))
270  (let* ((input-stream (make-instance 'cocoa-listener-input-stream))
271         (output-stream (make-instance 'cocoa-listener-output-stream
272                          :hemlock-view (hemlock-view window))))
273    (ccl::make-mcl-listener-process 
274     procname
275     input-stream
276     output-stream
277     ;; cleanup function
278     #'(lambda ()
279         (mapcar #'(lambda (buf)
280                     (when (eq (buffer-process buf) *current-process*)
281                       (let ((doc (hi::buffer-document buf)))
282                         (when doc
283                           (setf (hemlock-document-process doc) nil) ;; so #/close doesn't kill it.
284                           (cocoa-close doc nil)))))
285                 hi:*buffer-list*))
286     :initial-function
287     #'(lambda ()
288         (setq ccl::*listener-autorelease-pool* (create-autorelease-pool))
289         (when (and *standalone-cocoa-ide*
290                    (prog1 *first-listener* (setq *first-listener* nil)))
291           (ccl::startup-ccl (ccl::application-init-file ccl::*application*))
292           (ui-object-note-package *nsapp* *package*))
293         (funcall initial-function))
294     :echoing nil
295     :class class
296     :initargs `(:listener-input-stream ,input-stream
297                 :listener-output-stream ,output-stream
298                 :listener-window ,window
299                 ,@initargs))))
300 
301(defclass hemlock-listener-frame (hemlock-frame)
302    ()
303  (:metaclass ns:+ns-object))
304(declaim (special hemlock-listener-frame))
305
306(objc:defmethod (#/setDocumentEdited: :void) ((w hemlock-listener-frame)
307                                              (edited #>BOOL))
308  (declare (ignorable edited)))
309
310(defun window-type (w)
311  (type-of w))
312
313(defun maybe-close-all-windows-of-this-class (sender)
314  "Maybe forcibly close all windows of same class as window of current event, if any, and
315  if the option key was pressed. Returns t if we forcibly 'closed' window(s) here
316  (for some definition of 'close'), nil otherwise."
317  (let* ((event (#/currentEvent *nsapp*))
318         (modifiers (#/modifierFlags event))
319         (original-window (#/window event)))
320    (when (logtest #$NSAlternateKeyMask modifiers) ; check for option key pressed
321      (unless (%null-ptr-p original-window)
322        ;(format t "~%About to call map-windows for sender ~S" sender)
323        (map-windows #'(lambda (w) (when (and (eq (window-type w)
324                                                  (window-type original-window))
325                                              (not (#/isDocumentEdited w)))
326                                     (do-close-window w sender))))
327        ;(print "Called map-windows")
328        )
329      t)))
330
331(defmethod do-close-window ((w hemlock-listener-frame) sender)
332  "Forcibly 'close' this window, with some definition of 'close' that's right for this window class."
333  (let* ((doc (#/document (#/windowController w))))
334    (if (or (%null-ptr-p doc)
335            (null (hemlock-document-process doc)) 
336            (perform-close-kills-process-p doc))
337      (#/close w)
338      (progn
339        (#/orderOut: w sender)
340        ;(#/close w)
341        )))
342  nil ; tell system we already closed it
343  )
344
345(defmethod do-close-window ((w ns:ns-window) sender)
346  "Maybe forcibly 'close' this window, with some definition of 'close' that's right for this window class.
347  Return nil if we should let the system close it instead."
348  (declare (ignore sender))
349  (#/close w)
350  nil ; tell system we already closed it
351  )
352
353; This is a mess, but a necessary mess.
354; The reason this should ALWAYS return nil is because of the case where the option key is held
355; down and a window's close box is clicked. The proper behavior for a Lisp IDE is for all windows of
356; the same class as the first one to close. But we can't use the #/windowShouldClose mechanism for
357; this, because we have to somehow record the window class of the window that triggered the event in
358; the first place, and after that window is closed, we cannot then refer back to find out what kind
359; it was. And since I didn't want to introduce global variables, this is the next best thing:
360; When the option key is held down, forcibly close all the windows of the same class as the first,
361;   and tell #/windowShouldClose to always return nil so the system won't ever try to actually
362;   close anything. Note that the system does call #/windowShouldClose once for every window that's
363;   still open anyway. The first call to #/windowShouldClose establishes whether the option key
364;   was held down and if it was, it takes control away from the system and just closes the right
365;   windows then and there. If the option key was NOT held down, theoretically we could just return
366;   T and the system would take care of it, but because the 'closing' method on hemlock-listener-frames
367;   is complicated, we can't do this either. So we have complete lisp control over all window closing.
368
369; Well, almost.
370; There's still a slight bug when
371;  -- You have multiple open Hemlock windows, AND
372;  -- One or more of those windows contains modified but as-yet-unsaved content, and
373;  -- You option-close a listener window.
374; In that case, you'll get a "Do you want to save" dialog panel for the unsaved Hemlock window,
375;   when you shouldn't because you aren't trying to close Hemlock windows--you're trying to close
376;   listeners. But I haven't figured out a way to prevent this panel from showing up. Since it shows
377;   up BEFORE #/windowShouldClose is called, that function cannot stop it. It's a benign bug because
378;   it gives the user a chance to save unsaved files. And it's a rare case (because it's not common
379;   to have a bunch of listener windows that you want to close all at once anyway).
380;   But it's kind of annoying when it happens.
381
382(objc:defmethod (#/windowShouldClose: #>BOOL) ((w ns:ns-window)
383                                               sender)
384  (declare (ignorable sender))
385  ;(format t "~%In #/windowShouldClose for ~S" (or (window-pathname w) (class-of w) ))
386  (if (maybe-close-all-windows-of-this-class sender)
387    nil ; because maybe-close-all-windows-of-this-class already closed all that needed closing
388    (do-close-window w sender)))
389
390(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
391    ()
392  (:metaclass ns:+ns-object)
393  )
394(declaim (special hemlock-listener-window-controller))
395
396;;; Listener documents are never (or always) edited.  Don't cause their
397;;; close boxes to be highlighted.
398(objc:defmethod (#/setDocumentEdited: :void)
399    ((self hemlock-listener-window-controller) (edited :<BOOL>))
400  (declare (ignorable edited)))
401
402
403
404(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
405  (let* ((doc (#/document self)))
406    (if (or (%null-ptr-p doc)
407            (not (%null-ptr-p (#/fileURL doc))))
408      (call-next-method name)
409      (let* ((buffer (hemlock-buffer doc))
410             (bufname (if buffer (hi::buffer-name buffer))))
411        (if bufname
412          (let* ((bufname (%make-nsstring bufname))
413                 (seq (slot-value self 'sequence)))
414            (if (zerop seq)
415              bufname
416              (#/stringWithFormat: ns:ns-string #@"%@ <%d>" bufname seq)))
417          (call-next-method name))))))
418
419
420;;; The HemlockListenerDocument class.
421
422
423(defclass hemlock-listener-document (hemlock-editor-document)
424  ((process :reader %hemlock-document-process :writer (setf hemlock-document-process) :initform nil))
425  (:metaclass ns:+ns-object))
426(declaim (special hemlock-listener-document))
427
428(defgeneric hemlock-document-process (doc)
429  (:method ((unknown t)) nil)
430  (:method ((doc hemlock-listener-document)) (%hemlock-document-process doc)))
431
432;; Nowadays this is nil except for listeners.
433(defun buffer-process (buffer)
434  (hemlock-document-process (hi::buffer-document buffer)))
435
436(defmethod update-buffer-package ((doc hemlock-listener-document))
437  nil)
438
439(defmethod document-encoding-name ((doc hemlock-listener-document))
440  "UTF-8")
441
442(defmethod user-input-style ((doc hemlock-listener-document))
443  hi::*listener-input-style*)
444 
445(defmethod textview-background-color ((doc hemlock-listener-document))
446  *listener-background-color*)
447
448;; For use with the :process-info listener modeline field
449(defmethod hemlock-ext:buffer-process-description (buffer)
450  (let ((proc (buffer-process buffer)))
451    (when proc
452      (format nil "~a(~d) [~a]"
453              (ccl:process-name proc)
454              (ccl::process-serial-number proc)
455              ;; TODO: this doesn't really work as a modeline item, because the modeline
456              ;; doesn't get notified when it changes.
457              (ccl:process-whostate proc)))))
458
459(objc:defmethod #/topListener ((self +hemlock-listener-document))
460  (let* ((w (car (active-listener-windows))))
461    (if w
462      (#/document (#/windowController w))
463      +null-ptr+)))
464
465(defun top-listener-document ()
466  (let* ((doc (#/topListener hemlock-listener-document)))
467    (unless (%null-ptr-p doc) doc)))
468
469(defun top-listener-process ()
470  (let* ((doc (#/topListener hemlock-listener-document)))
471    (unless (%null-ptr-p doc)
472      (hemlock-document-process doc))))
473
474
475(defun symbol-value-in-top-listener-process (symbol)
476  (let* ((process (top-listener-process)))
477     (if process
478       (ignore-errors (symbol-value-in-process symbol process))
479       (values nil t))))
480 
481(defun hemlock-ext:top-listener-output-stream ()
482  (let* ((process (top-listener-process)))
483    (when process
484      (setq process (require-type process 'cocoa-listener-process))
485      (cocoa-listener-process-output-stream process))))
486
487(defun hemlock-ext:top-listener-input-stream ()
488  (let* ((process (top-listener-process)))
489    (when process
490      (setq process (require-type process 'cocoa-listener-process))
491      (cocoa-listener-process-input-stream process))))
492
493
494
495(objc:defmethod (#/isDocumentEdited :<BOOL>) ((self hemlock-listener-document))
496  nil)
497
498(defun listener-window-count ()
499  (let ((count 0)
500        (all-windows (#/windows *NSApp*)))
501    (dotimes (i (#/count all-windows) count)
502      (let* ((w (#/objectAtIndex: all-windows i))
503             (wc (#/windowController w)))
504        (when (typep wc 'hemlock-listener-window-controller)
505          (incf count))))))
506
507(objc:defmethod #/init ((self hemlock-listener-document))
508  (let* ((doc (call-next-method)))
509    (unless (%null-ptr-p doc)
510      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
511                              "Listener"
512                              (format nil
513                                      "Listener-~d" *cocoa-listener-count*)))
514             (buffer (hemlock-buffer doc)))
515        (setf (hi::buffer-pathname buffer) nil
516              (hi::buffer-minor-mode buffer "Listener") t
517              (hi::buffer-name buffer) listener-name)
518        (hi::set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
519    doc))
520
521(def-cocoa-default *initial-listener-x-pos* :float 100.0f0 "X position of upper-left corner of initial listener")
522
523(def-cocoa-default *initial-listener-y-pos* :float 100.0f0 "Y position of upper-left corner of initial listener")
524
525(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
526(defloadvar *next-listener-y-pos* nil) ; likewise
527
528(objc:defmethod (#/dealloc :void) ((self hemlock-listener-document))
529  (when (zerop (listener-window-count))
530    (setq *next-listener-x-pos* nil
531          *next-listener-y-pos* nil
532          *cocoa-listener-count* 0))
533  (let* ((p (hemlock-document-process self)))
534    (when p
535      (setf (hemlock-document-process self) nil)
536      (process-kill p)))
537  (call-next-method))
538
539
540
541
542(objc:defmethod (#/makeWindowControllers :void) ((self hemlock-listener-document))
543  (let* ((textstorage (slot-value self 'textstorage))
544         (window (%hemlock-frame-for-textstorage
545                  hemlock-listener-frame
546                  textstorage
547                  *listener-columns*
548                  *listener-rows*
549                  t
550                  (textview-background-color self)
551                  (user-input-style self)))
552         (listener-styles (#/arrayWithObjects: ns:ns-mutable-array
553                                               (rme-create-text-attributes
554                                                :font *listener-input-font*)
555                                               (rme-create-text-attributes
556                                                :font *listener-output-font*)
557                                               +null-ptr+))
558         (controller (make-instance
559                      'hemlock-listener-window-controller
560                      :with-window window))
561         (listener-name (hi::buffer-name (hemlock-buffer self)))
562         (path (#/windowTitleForDocumentDisplayName: controller (#/displayName self ))))
563    (when (slot-exists-p textstorage 'styles)
564      (with-slots (styles) textstorage
565        ;; We probably should be more disciplined about
566        ;; Cocoa memory management.  Having retain/release in
567        ;; random places all over the code is going to get
568        ;; unwieldy.
569        (#/release styles)
570        (setf styles (#/retain listener-styles))))
571    ;; Disabling background layout on listeners is an attempt to work
572    ;; around a bug.  The bug's probably gone ...
573    #-cocotron                          ;no concept of background layout
574    (let* ((layout-managers (#/layoutManagers textstorage)))
575      (dotimes (i (#/count layout-managers))
576        (let* ((layout (#/objectAtIndex: layout-managers i)))
577          (#/setBackgroundLayoutEnabled: layout nil))))
578    (#/setDelegate: window controller)
579    (#/setDelegate: (text-pane-text-view (slot-value window 'pane)) controller)
580    (setf (slot-value controller 'sequence)
581          (slot-value self 'dupcount))
582    (#/setShouldCascadeWindows: controller nil)
583    (#/addWindowController: self controller)
584    (#/release controller)
585    (unless (hemlock-document-process self)
586      (setf (hemlock-document-process self)
587            (new-cocoa-listener-process listener-name window)))
588    (when path
589      (unless (#/setFrameAutosaveName: window path)
590        (setq path nil)))
591    (unless (and path
592                 (when (#/setFrameUsingName: window path)
593                   (let* ((frame (#/frame window)))
594                     (ns:with-ns-point (current-point
595                                        (ns:ns-rect-x frame)
596                                        (+ (ns:ns-rect-y frame)
597                                           (ns:ns-rect-height frame)))
598                       (let* ((next-point (#/cascadeTopLeftFromPoint:
599                                           window
600                                           current-point)))
601                         (setq *next-listener-x-pos*
602                               (ns:ns-point-x next-point)
603                               *next-listener-y-pos*
604                               (ns:ns-point-y next-point)))))
605                   t))
606      (ns:with-ns-point (current-point
607                         (or *next-listener-x-pos*
608                             (x-pos-for-window window *initial-listener-x-pos*))
609                         (or *next-listener-y-pos*
610                             (y-pos-for-window window *initial-listener-y-pos*)))
611        (let* ((new-point (#/cascadeTopLeftFromPoint: window current-point)))
612          (setf *next-listener-x-pos* (ns:ns-point-x new-point)
613                *next-listener-y-pos* (ns:ns-point-y new-point)))))
614    (#/synchronizeWindowTitleWithDocumentName controller)
615    controller))
616
617(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
618    ((self hemlock-listener-document)
619     tv
620     (range :<NSR>ange)
621     string)
622  (declare (ignore tv string))
623  (let* ((range-start (ns:ns-range-location range))
624         (range-end (+ range-start (ns:ns-range-length range)))
625         (buffer (hemlock-buffer self))
626         (protected-region (hi::buffer-protected-region buffer)))
627    (if protected-region
628      (let* ((prot-start (hi:mark-absolute-position (hi::region-start protected-region)))
629             (prot-end (hi:mark-absolute-position (hi::region-end protected-region))))
630        (not (or (and (>= range-start prot-start)
631                      (< range-start prot-end))
632                 (and (>= range-end prot-start)
633                      (< range-end prot-end)))))
634      t)))
635
636
637;;; Action methods
638(objc:defmethod (#/interrupt: :void) ((self hemlock-listener-document) sender)
639  (declare (ignore sender))
640  (let* ((process (hemlock-document-process self)))
641    (when process
642      (ccl::force-break-in-listener process))))
643
644
645
646(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
647  (declare (ignore sender))
648  (let* ((process (hemlock-document-process self)))
649    #+debug (log-debug  "~&exitBreak process ~s" process)
650    (when process
651      (process-interrupt process #'abort-break))))
652
653(defmethod listener-backtrace-context ((proc cocoa-listener-process))
654  (car (cocoa-listener-process-backtrace-contexts proc)))
655
656(objc:defmethod (#/backtrace: :void) ((self hemlock-listener-document) sender)
657  (let* ((process (hemlock-document-process self)))
658    (when process
659      (let* ((context (listener-backtrace-context process)))
660        (when context
661          (#/makeKeyAndOrderFront: (#/windowForSheet self) nil)
662          (#/showWindow: (backtrace-controller-for-context context) sender))))))
663
664(defun restarts-controller-for-context (context)
665  (or (backtrace-context-restarts-window context)
666      (setf (backtrace-context-restarts-window context) (restarts-dialog context))))
667
668(defmethod restarts-dialog ((context vector))
669  (let* ((tcr (ccl::bt.tcr context))
670         (tsp-range (ccl::make-tsp-stack-range tcr context))
671         (vsp-range (ccl::make-vsp-stack-range tcr context))
672         (csp-range (ccl::make-csp-stack-range tcr context))
673         (process (ccl::tcr->process tcr)))
674    (make-instance 'sequence-window-controller
675      :sequence (cdr (ccl::bt.restarts context))
676      :before-close-function #'(lambda (wc)
677                                 (declare (ignore wc))
678                                 (setf (car (ccl::bt.restarts context)) nil))
679      :result-callback #'(lambda (r)
680                           (execute-in-gui #'(lambda ()
681                                               (#/close (car (ccl::bt.restarts context)))))
682                           (process-interrupt
683                            process
684                            #'invoke-restart-interactively
685                            r))
686      :display #'(lambda (item stream)
687                   (let* ((ccl::*aux-vsp-ranges* vsp-range)
688                          (ccl::*aux-tsp-ranges* tsp-range)
689                          (ccl::*aux-csp-ranges* csp-range))
690                     (princ item stream)))
691      :title (format nil "Restarts for ~a(~d), break level ~d"
692                     (process-name process)
693                     (process-serial-number process)
694                     (ccl::backtrace-context-break-level context)))))
695
696(objc:defmethod (#/restarts: :void) ((self hemlock-listener-document) sender)
697  (let* ((process (hemlock-document-process self)))
698    (when process
699      (let* ((context (listener-backtrace-context process)))
700        (when context
701          (#/showWindow: (restarts-controller-for-context context) sender))))))
702
703(objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
704  (declare (ignore sender))
705  (let* ((process (hemlock-document-process self)))
706    (when process
707      (let* ((context (listener-backtrace-context process)))
708        (when context
709          (process-interrupt process #'invoke-restart-interactively 'continue))))))
710
711;;; Menu item action validation.  It'd be nice if we could distribute this a
712;;; bit better, so that this method didn't have to change whenever a new
713;;; action was implemented in this class.  For now, we have to do so.
714
715(defmethod document-validate-menu-item ((doc hemlock-listener-document) item)
716  ;; Return two values: the first is true if the second is definitive.
717  ;; So far, all actions demand that there be an underlying process, so
718  ;; check for that first.
719  (let* ((process (hemlock-document-process doc)))
720    (if process
721      (let* ((action (#/action item)))
722        (cond
723          ((or (eql action (@selector #/revertDocumentToSaved:))
724               (eql action (@selector #/saveDocument:))
725               (eql action (@selector #/saveDocumentAs:)))
726           (values t nil))
727          ((eql action (@selector #/interrupt:)) (values t t))
728          ((eql action (@selector #/continue:))
729           (let* ((context (listener-backtrace-context process)))
730             (values
731              t
732              (and context
733                   (ccl::backtrace-context-continuable-p context)))))
734          ((or (eql action (@selector #/backtrace:))
735               (eql action (@selector #/exitBreak:))
736               (eql action (@selector #/restarts:)))
737           (values t
738                   (not (null (listener-backtrace-context process)))))))
739      (values nil nil))))
740
741(objc:defmethod (#/validateMenuItem: :<BOOL>)
742    ((self hemlock-listener-document) item)
743  (multiple-value-bind (have-opinion opinion)
744      (document-validate-menu-item self item)
745    (if have-opinion
746      opinion
747      (call-next-method item))))
748
749(defmethod perform-close-kills-process-p ((self hemlock-listener-document))
750  t)
751
752(defmethod ui-object-note-package ((app ns:ns-application) package)
753  (let ((proc *current-process*))
754    (execute-in-gui #'(lambda ()
755                        (dolist (buf hi::*buffer-list*)
756                          (when (eq proc (buffer-process buf))
757                            (let ((hi::*current-buffer* buf))
758                              (hemlock:update-current-package package))))))))
759
760
761(defmethod eval-in-listener-process ((process cocoa-listener-process)
762                                     string &key path package offset)
763  (enqueue-toplevel-form (cocoa-listener-process-input-stream process) string
764                         :package-name package :pathname path :offset offset))
765
766;;; This is basically used to provide INPUT to the listener process, by
767;;; writing to an fd which is connected to that process's standard
768;;; input.
769(defun hemlock-ext:send-string-to-listener (listener-buffer string)
770  (let* ((process (buffer-process listener-buffer)))
771    (unless process
772      (error "No listener process found for ~s" listener-buffer))
773    (enqueue-listener-input (cocoa-listener-process-input-stream process) string)))
774
775(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
776                                                    selection)
777  (declare (ignore selection))
778  (#/performSelectorOnMainThread:withObject:waitUntilDone:
779   (#/delegate *NSApp*)
780   (@selector #/ensureListener:)
781   +null-ptr+
782   #$YES)
783  (top-listener-process))
784
785(defmethod ui-object-eval-selection ((app ns:ns-application)
786                                     selection)
787  (let* ((target-listener (ui-object-choose-listener-for-selection
788                           app selection)))
789    (when target-listener
790      (destructuring-bind (package path string &optional offset) selection
791        (eval-in-listener-process target-listener string :package package :path path :offset offset)))))
792
793(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
794  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
795    (when target-listener
796      (destructuring-bind (package path) selection
797        (let ((string (format nil "(cl:load ~S)" path)))
798          (eval-in-listener-process target-listener string :package package))))))
799
800(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
801  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
802    (when target-listener
803      (destructuring-bind (package path) selection
804        (let ((string (format nil "(cl:compile-file ~S)" path)))
805          (eval-in-listener-process target-listener string :package package))))))
806
807(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
808  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
809    (when target-listener
810      (destructuring-bind (package path) selection
811        (let ((string (format nil "(cl:progn (cl:compile-file ~S) (cl:load ~S))" 
812                              path
813                              (make-pathname :directory (pathname-directory path)
814                                             :name (pathname-name path)
815                                             :type (pathname-type path)))))
816          (eval-in-listener-process target-listener string :package package))))))
817
818       
819;;; Support for background processes that acquire listener window/document/
820;;; buffer infrastructure iff they try to do I/O to *TERMINAL-IO*.
821
822(defclass hemlock-background-listener-document (hemlock-listener-document)
823    ()
824  (:metaclass ns:+ns-object))
825
826(defmethod perform-close-kills-process-p ((self hemlock-background-listener-document))
827  nil)
828
829(defstruct deferred-cocoa-listener-stream-info
830  real-input-stream
831  real-output-stream
832  process
833  window)
834
835   
836(defclass deferred-cocoa-listener-stream (fundamental-character-stream)
837    ((info :initarg :info :accessor deferred-cocoa-listener-stream-info)))
838
839(defmethod ensure-deferred-stream-info-for-io ((s deferred-cocoa-listener-stream))
840  (let* ((info (slot-value s 'info)))
841    (when info
842      (unless (deferred-cocoa-listener-stream-info-window info)
843        (with-autorelease-pool
844            (let* ((doc (execute-in-gui (lambda () (make-instance 'hemlock-background-listener-document))))
845                   (buffer (hemlock-buffer doc))
846                   (process (deferred-cocoa-listener-stream-info-process info)))
847              (setf (hi::buffer-name buffer)
848                    (format nil "~a(~d)" (process-name process) (process-serial-number process))
849                    (hemlock-document-process doc) process)
850              (execute-in-gui (lambda () (#/makeWindowControllers doc)))
851              (let* ((wc (#/lastObject (#/windowControllers doc)))
852                     (window (#/window wc)))
853                (setf
854                 (deferred-cocoa-listener-stream-info-real-input-stream info)
855                 (make-instance 'cocoa-listener-input-stream)
856                 (deferred-cocoa-listener-stream-info-real-output-stream info)
857                 (make-instance 'cocoa-listener-output-stream
858                                :hemlock-view (hemlock-view window))
859                 (deferred-cocoa-listener-stream-info-window info)
860                 window
861                 (slot-value process 'window) window)
862                (ui-object-note-package *nsapp* *package*))))))
863    info))
864               
865                     
866
867(defclass deferred-cocoa-listener-output-stream
868          (fundamental-character-output-stream deferred-cocoa-listener-stream)
869    ())
870
871(defmethod stream-element-type ((s deferred-cocoa-listener-output-stream))
872  'character)
873
874
875(defmethod underlying-output-stream ((s deferred-cocoa-listener-output-stream))
876  (let* ((info (ensure-deferred-stream-info-for-io s)))
877    (if info
878      (progn
879        (let* ((window (deferred-cocoa-listener-stream-info-window info)))
880          (unless (#/isVisible window)
881            (execute-in-gui
882             (lambda ()
883               (#/makeKeyAndOrderFront: window (%null-ptr)))))
884          (deferred-cocoa-listener-stream-info-real-output-stream info)))
885      (ccl::stream-is-closed s))))
886
887(defmethod ccl:stream-write-char ((s deferred-cocoa-listener-output-stream)
888                                  char)
889  (with-autorelease-pool
890      (stream-write-char (underlying-output-stream s) char)))
891
892(defmethod ccl:stream-line-column ((s deferred-cocoa-listener-output-stream))
893  (stream-line-column (underlying-output-stream s)))
894
895(defmethod ccl:stream-fresh-line ((s deferred-cocoa-listener-output-stream))
896  (stream-fresh-line (underlying-output-stream s)))
897
898(defmethod ccl::stream-finish-output ((s deferred-cocoa-listener-output-stream))
899  (stream-force-output s))
900
901(defmethod ccl:stream-force-output ((s deferred-cocoa-listener-output-stream))
902  (let* ((info (slot-value s 'info)))
903    (if info
904      (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info)))
905        (if out
906          (stream-force-output out)))
907      (ccl::stream-is-closed s))))
908
909(defmethod ccl:stream-clear-output ((s deferred-cocoa-listener-output-stream))
910  (stream-clear-output (underlying-output-stream s)))
911
912(defmethod ccl:stream-line-length ((s deferred-cocoa-listener-output-stream))
913  (stream-line-length (underlying-output-stream s)))
914
915(defmethod close ((s deferred-cocoa-listener-output-stream)
916                  &key abort)
917  (let* ((info (slot-value s 'info)))
918    (when info
919      (let* ((out (deferred-cocoa-listener-stream-info-real-output-stream info)))
920        (when out
921          (stream-force-output out)
922          (close out :abort abort)))
923      (setf (slot-value s 'info) nil)
924      t)))
925         
926
927(defclass deferred-cocoa-listener-input-stream
928          (fundamental-character-input-stream deferred-cocoa-listener-stream)
929    ((reading-line :initform nil :accessor hi:input-stream-reading-line)))
930
931
932(defmethod underlying-input-stream ((s deferred-cocoa-listener-input-stream))
933  (let* ((info (ensure-deferred-stream-info-for-io s)))
934    (if info
935      (progn
936        (let* ((window (deferred-cocoa-listener-stream-info-window info)))
937          (unless (#/isVisible window)
938            (execute-in-gui
939             (lambda ()
940               (#/makeKeyAndOrderFront: window (%null-ptr)))))
941          (deferred-cocoa-listener-stream-info-real-input-stream info)))
942      (ccl::stream-is-closed s))))
943
944(defmethod interactive-stream-p ((s deferred-cocoa-listener-input-stream))
945  t)
946
947(defmethod ccl::read-toplevel-form ((s deferred-cocoa-listener-input-stream)
948                                    &key eof-value)
949  (ccl::read-toplevel-form (underlying-input-stream s) :eof-value eof-value))
950
951(defmethod enqueue-toplevel-form ((s deferred-cocoa-listener-input-stream) string &rest args &key &allow-other-keys)
952  (apply #'enqueue-toplevel-form (underlying-input-stream s) string args))
953
954(defmethod enqueue-listener-input ((s deferred-cocoa-listener-input-stream) string)
955  (enqueue-listener-input (underlying-input-stream s) string))
956
957(defmethod stream-read-char-no-hang ((s deferred-cocoa-listener-input-stream))
958  (stream-read-char-no-hang (underlying-input-stream s)))
959
960(defmethod stream-read-char ((s deferred-cocoa-listener-input-stream))
961  (stream-read-char (underlying-input-stream s)))
962
963(defmethod stream-unread-char ((s deferred-cocoa-listener-input-stream) char)
964  (stream-unread-char (underlying-input-stream s) char))
965
966(defmethod stream-clear-input ((s deferred-cocoa-listener-input-stream))
967  (stream-clear-input (underlying-input-stream s)))
968
969(defmethod stream-read-line ((s deferred-cocoa-listener-input-stream))
970  (let* ((old-reading-line (hi:input-stream-reading-line s)))
971    (unwind-protect
972         (progn
973           (setf (hi::input-stream-reading-line s) t)
974           (stream-read-line (underlying-input-stream s)))
975      (setf (hi:input-stream-reading-line s) old-reading-line))))
976
977(defclass background-cocoa-listener-process (cocoa-listener-process)
978    ())
979
980(defun background-process-run-function (keywords function)
981  (unless (listp keywords)
982    (setf keywords (list :name keywords)))
983  (destructuring-bind (&key (name "Anonymous")
984                            (priority  0)
985                            (stack-size ccl::*default-control-stack-size*)
986                            (vstack-size ccl::*default-value-stack-size*)
987                            (tstack-size ccl::*default-temp-stack-size*)
988                            (initial-bindings ())
989                            (persistent nil)
990                            (use-standard-initial-bindings t)
991                            (termination-semaphore nil)
992                            (allocation-quantum (default-allocation-quantum)))
993                      keywords
994    (setq priority (require-type priority 'fixnum))
995    (let* ((process (make-process name
996                                  :class 'background-cocoa-listener-process
997                                  :priority priority
998                                  :stack-size stack-size
999                                  :vstack-size vstack-size
1000                                  :tstack-size tstack-size
1001                                  :persistent persistent
1002                                  :use-standard-initial-bindings use-standard-initial-bindings
1003                                  :initial-bindings initial-bindings
1004                                  :termination-semaphore termination-semaphore
1005                                  :allocation-quantum allocation-quantum))
1006           (info (make-deferred-cocoa-listener-stream-info :process process))
1007           (input-stream (make-instance 'deferred-cocoa-listener-input-stream
1008                           :info info))
1009           (output-stream (make-instance 'deferred-cocoa-listener-output-stream
1010                            :info info)))
1011      (setf (slot-value process 'input-stream) input-stream
1012            (slot-value process 'output-stream) output-stream)
1013      (process-preset process
1014                      (lambda ()
1015                        (let* ((*terminal-io* (make-two-way-stream input-stream output-stream)))
1016                          (ccl::add-auto-flush-stream output-stream)
1017                          (unwind-protect
1018                              (funcall function)
1019                            (remove-auto-flush-stream output-stream)
1020                            (let* ((w (slot-value process 'window)))
1021                              (when w
1022                                (let* ((doc (#/document w)))
1023                                  (unless (%null-ptr-p doc)
1024                                    (when (eq *current-process*
1025                                              (hemlock-document-process doc))
1026                                      (setf (hemlock-document-process doc) nil))))
1027                                (cond ((#/isVisible w)
1028                                       (format output-stream "~%~%{process ~s exiting}~%" *current-process*))
1029                                      (t
1030                                       (cocoa-close w t)))
1031                                (close input-stream)
1032                                (close output-stream)))))))
1033      (process-enable process))))
Note: See TracBrowser for help on using the repository browser.