Index: /trunk/ccl/examples/cocoa-editor.lisp =================================================================== --- /trunk/ccl/examples/cocoa-editor.lisp (revision 591) +++ /trunk/ccl/examples/cocoa-editor.lisp (revision 592) @@ -6,20 +6,942 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (require "COCOA-WINDOW") - (require "HEMLOCK-TEXTSTORAGE")) - -(declaim - (special *open-editor-documents* *open-editor-documents-lock*) - (type list *open-editor-documents*) - (type lock *open-editor-documents-lock*)) - - -(defstruct cocoa-editor-info - (document nil) ; the NSDocument - (controller nil) ; the NSWindowController (maybe). - (listener nil) ; True (a lisp process) if a listener - (modeline-plist nil) ; info from attribute line -) - - + (require "HEMLOCK")) + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :cocoa)) + +(defun make-hemlock-buffer (&rest args) + (let* ((buf (apply #'hi::make-buffer args))) + (or buf + (progn + (format t "~& couldn't make hemlock buffer with args ~s" args) + (dbg) + nil)))) + +;;; Define some key event modifiers. + +;;; HEMLOCK-EXT::DEFINE-CLX-MODIFIER is kind of misnamed; we can use +;;; it to map NSEvent modifier keys to key-event modifiers. + +(hemlock-ext::define-clx-modifier #$NSShiftKeyMask "Shift") +(hemlock-ext::define-clx-modifier #$NSControlKeyMask "Control") +(hemlock-ext::define-clx-modifier #$NSAlternateKeyMask "Meta") +(hemlock-ext::define-clx-modifier #$NSAlphaShiftKeyMask "Lock") + + +;;; We want to display a Hemlock buffer in a "pane" (an on-screen +;;; view) which in turn is presented in a "frame" (a Cocoa window). A +;;; 1:1 mapping between frames and panes seems to fit best into +;;; Cocoa's document architecture, but we should try to keep the +;;; concepts separate (in case we come up with better UI paradigms.) +;;; Each pane has a modeline (which describes attributes of the +;;; underlying document); each frame has an echo area (which serves +;;; to display some commands' output and to provide multi-character +;;; input.) + + +;;; I'd pretty much concluded that it wouldn't be possible to get the +;;; Cocoa text system (whose storage model is based on NSString +;;; NSMutableAttributedString, NSTextStorage, etc.) to get along with +;;; Hemlock, and (since the whole point of using Hemlock was to be +;;; able to treat an editor buffer as a rich lisp data structure) it +;;; seemed like it'd be necessary to toss the higher-level Cocoa text +;;; system and implement our own scrolling, redisplay, selection +;;; ... code. +;;; +;;; Mikel Evins pointed out that NSString and friends were +;;; abstract classes and that there was therefore no reason (in +;;; theory) not to implement a thin wrapper around a Hemlock buffer +;;; that made it act like an NSString. As long as the text system can +;;; ask a few questions about the NSString (its length and the +;;; character and attributes at a given location), it's willing to +;;; display the string in a scrolling, mouse-selectable NSTextView; +;;; as long as Hemlock tells the text system when and how the contents +;;; of the abstract string changes, Cocoa will handle the redisplay +;;; details. +;;; + + + +;;; Hemlock-buffer-string objects: + +(defclass hemlock-buffer-string (ns:ns-string) + ((cache :initform nil :initarg :cache :accessor hemlock-buffer-string-cache)) + (:metaclass ns:+ns-object)) + +;;; Cocoa wants to treat the buffer as a linear array of characters; +;;; Hemlock wants to treat it as a doubly-linked list of lines, so +;;; we often have to map between an absolute position in the buffer +;;; and a relative position on a line. We can certainly do that +;;; by counting the characters in preceding lines every time that we're +;;; asked, but we're often asked to map a sequence of nearby positions +;;; and wind up repeating a lot of work. Caching the results of that +;;; work seems to speed things up a bit in many cases; this data structure +;;; is used in that process. (It's also the only way to get to the +;;; actual underlying Lisp buffer from inside the network of text-system +;;; objects.) + +(defstruct buffer-cache + buffer ; the hemlock buffer + buflen ; length of buffer, if known + workline ; cache for character-at-index + workline-offset ; cached offset of workline + workline-length ; length of cached workline + ) + +;;; Initialize (or reinitialize) a buffer cache, so that it points +;;; to the buffer's first line (which is the only line whose +;;; absolute position will never change). Code which modifies the +;;; buffer generally has to call this, since any cached information +;;; might be invalidated by the modification. +(defun reset-buffer-cache (d &optional (buffer (buffer-cache-buffer d) + buffer-p)) + (when buffer-p (setf (buffer-cache-buffer d) buffer)) + (let* ((workline (hemlock::mark-line + (hemlock::buffer-start-mark buffer)))) + (setf (buffer-cache-buflen d) (hemlock-buffer-length buffer) + (buffer-cache-workline-offset d) 0 + (buffer-cache-workline d) workline + (buffer-cache-workline-length d) (hemlock::line-length workline)) + d)) + + +;;; Update the cache so that it's describing the current absolute +;;; position. +(defun update-line-cache-for-index (cache index) + (let* ((line (or + (buffer-cache-workline cache) + (progn + (reset-buffer-cache cache) + (buffer-cache-workline cache)))) + (pos (buffer-cache-workline-offset cache)) + (len (buffer-cache-workline-length cache)) + (moved nil)) + (loop + (when (and (>= index pos) + (< index (1+ (+ pos len)))) + (let* ((idx (- index pos))) + (when moved + (setf (buffer-cache-workline cache) line + (buffer-cache-workline-offset cache) pos + (buffer-cache-workline-length cache) len)) + (return (values line idx)))) + (setq moved t) + (if (< index pos) + (setq line (hemlock::line-previous line) + len (hemlock::line-length line) + pos (1- (- pos len))) + (setq line (hemlock::line-next line) + pos (1+ (+ pos len)) + len (hemlock::line-length line)))))) + +;;; Ask Hemlock to count the characters in the buffer. +(defun hemlock-buffer-length (buffer) + (hemlock::count-characters (hemlock::buffer-region buffer))) + +;;; Find the line containing (or immediately preceding) index, which is +;;; assumed to be less than the buffer's length. Return the character +;;; in that line or the trailing #\newline, as appropriate. +(defun hemlock-char-at-index (cache index) + (multiple-value-bind (line idx) (update-line-cache-for-index cache index) + (let* ((len (hemlock::line-length line))) + (if (< idx len) + (hemlock::line-character line idx) + #\newline)))) + +;;; Given an absolute position, move the specified mark to the appropriate +;;; offset on the appropriate line. +(defun move-hemlock-mark-to-absolute-position (mark cache abspos) + (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos) + (hemlock::move-to-position mark idx line))) + +;;; Return the absolute position of the mark in the containing buffer. +;;; This doesn't use the caching mechanism, so it's always linear in the +;;; number of preceding lines. +(defun mark-absolute-position (mark) + (let* ((pos (hemlock::mark-charpos mark))) + (do* ((line (hemlock::line-previous (hemlock::mark-line mark)) + (hemlock::line-previous line))) + ((null line) pos) + (incf pos (1+ (hemlock::line-length line)))))) + +;;; Return the length of the abstract string, i.e., the number of +;;; characters in the buffer (including implicit newlines.) +(define-objc-method ((:unsigned length) + hemlock-buffer-string) + (let* ((cache (hemlock-buffer-string-cache self))) + (or (buffer-cache-buflen cache) + (setf (buffer-cache-buflen cache) + (hemlock-buffer-length (buffer-cache-buffer cache)))))) + + +;;; Return the character at the specified index (as a :unichar.) +(define-objc-method ((:unichar :character-at-index (unsigned index)) + hemlock-buffer-string) + (char-code (hemlock-char-at-index (hemlock-buffer-string-cache self) index))) + + +;;; Return an NSData object representing the bytes in the string. If +;;; the underlying buffer uses #\linefeed as a line terminator, we can +;;; let the superclass method do the work; otherwise, we have to +;;; ensure that each line is terminated according to the buffer's +;;; conventions. +(define-objc-method ((:id :data-using-encoding (:tringncoding encoding) + :allow-lossy-conversion (: flag)) + hemlock-buffer-string) + (let* ((buffer (buffer-cache-buffer (hemlock-buffer-string-cache self))) + (external-format (if buffer (hi::buffer-external-format buffer ))) + (raw-length (if buffer (hemlock-buffer-length buffer) 0))) + (if (eql 0 raw-length) + (make-objc-instance 'ns:ns-mutable-data :with-length 0) + (case external-format + ((:unix nil) + (send-super :data-using-encoding encoding :allow-lossy-conversion flag)) + ((:macos :cp/m) + (let* ((cp/m-p (eq external-format :cp/m))) + (when cp/m-p + ;; This may seem like lot of fuss about an ancient OS and its + ;; odd line-termination conventions. Of course, I'm actually + ;; referring to CP/M-86. + (do* ((line (hi::mark-line (hi::buffer-start-mark buffer)) + next) + (next (hi::line-next line) (hi::line-next line))) + ((null line)) + (when next (incf raw-length)))) + (let* ((pos 0) + (data (make-objc-instance 'ns:ns-mutable-data + :with-length raw-length)) + (bytes (send data 'mutable-bytes))) + (do* ((line (hi::mark-line (hi::buffer-start-mark buffer)) + next) + (next (hi::line-next line) (hi::line-next line))) + ((null line) data) + (let* ((chars (hi::line-chars line)) + (len (length chars))) + (unless (zerop len) + (%copy-ivector-to-ptr chars 0 bytes pos len) + (incf pos len)) + (when next + (setf (%get-byte bytes pos) (char-code #\return)) + (when cp/m-p + (incf pos) + (setf (%get-byte bytes pos) (char-code #\linefeed)) + (incf pos)))))))))))) + + +;;; For debugging, mostly: make the printed representation of the string +;;; referenence the named Hemlock buffer. +(define-objc-method ((:id description) + hemlock-buffer-string) + (let* ((cache (hemlock-buffer-string-cache self)) + (b (buffer-cache-buffer cache))) + (with-cstrs ((s (format nil "~a" b))) + (send (@class ns-string) :string-with-format #@"<%s for %s>" + (:address (#_object_getClassName self) :address s))))) + + + + +;;; Lisp-text-storage objects +(defclass lisp-text-storage (ns:ns-text-storage) + ((string :foreign-type :id) + (defaultattrs :foreign-type :id)) + (:metaclass ns:+ns-object)) + +;;; Access the string. It'd be nice if this was a generic function; +;;; we could have just made a reader method in the class definition. +(define-objc-method ((:id string) lisp-text-storage) + (slot-value self 'string)) + +(define-objc-method ((:id :init-with-string s) lisp-text-storage) + (let* ((newself (send-super 'init))) + (setf (slot-value newself 'string) s + (slot-value newself 'defaultattrs) (create-text-attributes)) + newself)) + +;;; This is the only thing that's actually called to create a +;;; lisp-text-storage object. (It also creates the underlying +;;; hemlock-buffer-string.) +(defun make-textstorage-for-hemlock-buffer (buffer) + (make-objc-instance 'lisp-text-storage + :with-string + (make-instance + 'hemlock-buffer-string + :cache + (reset-buffer-cache + (make-buffer-cache) + buffer)))) + +;;; So far, we're ignoring Hemlock's font-marks, so all characters in +;;; the buffer are presumed to have default attributes. +(define-objc-method ((:id :attributes-at-index (:unsigned index) + :effective-range ((* :ange) rangeptr)) + lisp-text-storage) + (declare (ignorable index)) + (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string))) + (len (buffer-cache-buflen buffer-cache))) + (unless (%null-ptr-p rangeptr) + (setf (pref rangeptr :ange.location) 0 + (pref rangeptr :ange.length) len)) + (slot-value self 'defaultattrs))) + +;;; The range's origin should probably be the buffer's point; if +;;; the range has non-zero length, we probably need to think about +;;; things harder. +(define-objc-method ((:void :replace-characters-in-range (:ange r) + :with-string string) + lisp-text-storage) + (#_NSLog #@"replace-characters-in-range (%d %d) with-string %@" + :unsigned (pref r :ange.location) + :unsigned (pref r :ange.length) + :id string)) + +;;; I'm not sure if we want the text system to be able to change +;;; attributes in the buffer. +(define-objc-method ((:void :set-attributes attributes + :range (:ange r)) + lisp-text-storage) + (#_NSLog #@"set-attributes %@ range (%d %d)" + :id attributes + :unsigned (pref r :ange.location) + :unsigned (pref r :ange.length))) + + +;;; Again, it's helpful to see the buffer name when debugging. +(define-objc-method ((:id description) + lisp-text-storage) + (send (@class ns-string) :string-with-format #@"%s : string %@" + (:address (#_object_getClassName self) :id (slot-value self 'string)))) + +(defun close-hemlock-textstorage (ts) + (let* ((string (slot-value ts 'string))) + (setf (slot-value ts 'string) (%null-ptr)) + (unless (%null-ptr-p string) + (let* ((cache (hemlock-buffer-string-cache string)) + (buffer (if cache (buffer-cache-buffer cache)))) + (when buffer + (setf (buffer-cache-buffer cache) nil + (slot-value string 'cache) nil + (hi::buffer-document buffer) nil) + (let* ((p (hi::buffer-process buffer))) + (when p + (setf (hi::buffer-process buffer) nil) + (process-kill p))) + (when (eq buffer hi::*current-buffer*) + (setf (hi::current-buffer) + (car (last hi::*buffer-list*)))) + (hi::invoke-hook (hi::buffer-delete-hook buffer) buffer) + (hi::invoke-hook hemlock::delete-buffer-hook buffer) + (setq hi::*buffer-list* (delq buffer hi::*buffer-list*)) + (hi::delete-string (hi::buffer-name buffer) hi::*buffer-names*)))))) + + + + + + +;;; A specialized NSTextView. Some of the instance variables are intended +;;; to support paren highlighting by blinking, but that doesn't work yet. +;;; The NSTextView is part of the "pane" object that displays buffers. +(defclass hemlock-text-view (ns:ns-text-view) + ((timer :foreign-type :id :accessor blink-timer) + (blink-pos :foreign-type :int :accessor blink-pos) + (blink-phase :foreign-type : :accessor blink-phase) + (blink-char :foreign-type :int :accessor blink-char) + (pane :foreign-type :id :accessor text-view-pane)) + (:metaclass ns:+ns-object)) + +;;; Access the underlying buffer in one swell foop. +(defmethod text-view-buffer ((self hemlock-text-view)) + (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string)))) + +;;; Translate a keyDown NSEvent to a Hemlock key-event. +(defun nsevent-to-key-event (nsevent) + (let* ((unmodchars (send nsevent 'characters-ignoring-modifiers)) + (n (if (%null-ptr-p unmodchars) + 0 + (send unmodchars 'length))) + (c (if (eql n 1) + (send unmodchars :character-at-index 0)))) + (when c + (let* ((bits 0) + (modifiers (send nsevent 'modifier-flags)) + (useful-modifiers (logandc2 modifiers + (logior #$NSShiftKeyMask + #$NSAlphaShiftKeyMask)))) + (dolist (map hemlock-ext::*modifier-translations*) + (when (logtest useful-modifiers (car map)) + (setq bits (logior bits (hemlock-ext::key-event-modifier-mask + (cdr map)))))) + (hemlock-ext::make-key-event c bits))))) + +;;; Process a key-down NSEvent in a lisp text view by translating it +;;; into a Hemlock key event and passing it into the Hemlock command +;;; interpreter. The underlying buffer becomes Hemlock's current buffer +;;; and the containing pane becomes Hemlock's current window when the +;;; command is processed. Use the frame's command state object. + +(define-objc-method ((:void :key-down event) + hemlock-text-view) + #+debug + (#_NSLog #@"Key down event = %@" :address event) + (let* ((buffer (text-view-buffer self))) + (when buffer + (let* ((info (hemlock-frame-command-info (send self 'window)))) + (when info + (let* ((key-event (nsevent-to-key-event event))) + (when event + (unless (eq buffer hi::*current-buffer*) + (setf (hi::current-buffer) buffer)) + (let* ((pane (text-view-pane self))) + (unless (eql pane (hi::current-window)) + (setf (hi::current-window) pane))) + #+debug + (format t "~& key-event = ~s" key-event) + (hi::interpret-key-event key-event info)))))))) + +;;; Update the underlying buffer's point. Should really set the +;;; active region (in Hemlock terms) as well. +(define-objc-method ((:void :set-selected-range (:ange r) + :affinity (:electionffinity affinity) + :still-selecting (: still-selecting)) + hemlock-text-view) + (let* ((d (hemlock-buffer-string-cache (send self 'string))) + (point (hemlock::buffer-point (buffer-cache-buffer d))) + (location (pref r :ange.location)) + (len (pref r :ange.length))) + (when (eql len 0) + (move-hemlock-mark-to-absolute-position point d location)) + (send-super :set-selected-range r + :affinity affinity + :still-selecting still-selecting))) + + + + +;;; Modeline-view + +;;; The modeline view is embedded in the horizontal scroll bar of the +;;; scrollview which surrounds the textview in a pane. (A view embedded +;;; in a scrollbar like this is sometimes called a "placard"). Whenever +;;; the view's invalidated, its drawRect: method draws a string containing +;;; the current values of the buffer's modeline fields. + +(defclass modeline-view (ns:ns-view) + ((pane :foreign-type :id :accessor modeline-view-pane)) + (:metaclass ns:+ns-object)) + + +;;; Attributes to use when drawing the modeline fields. There's no +;;; simple way to make the "placard" taller, so using fonts larger than +;;; about 12pt probably wouldn't look too good. 10pt Courier's a little +;;; small, but allows us to see more of the modeline fields (like the +;;; full pathname) in more cases. +(defloadvar *modeline-text-attributes* nil) +(defparameter *modeline-font-name* "Courier New Bold Italic") +(defparameter *modeline-font-size* 10.0) + + +;;; Find the underlying buffer. +(defun buffer-for-modeline-view (mv) + (let* ((pane (modeline-view-pane mv))) + (unless (%null-ptr-p pane) + (let* ((tv (text-pane-text-view pane))) + (unless (%null-ptr-p tv) + (text-view-buffer tv)))))) + +;;; Draw a string in the modeline view. The font and other attributes +;;; are initialized lazily; apparently, calling the Font Manager too +;;; early in the loading sequence confuses some Carbon libraries that're +;;; used in the event dispatch mechanism, +(defun draw-modeline-string (modeline-view) + (let* ((pane (modeline-view-pane modeline-view)) + (buffer (buffer-for-modeline-view modeline-view))) + (when buffer + ;; You don't want to know why this is done this way. + (unless *modeline-text-attributes* + (setq *modeline-text-attributes* + (create-text-attributes :color (send (@class "NSColor") 'black-color) + :font (default-font + :name *modeline-font-name* + :size *modeline-font-size*)))) + + (let* ((string + (apply #'concatenate 'string + (mapcar + #'(lambda (field) + (funcall (hi::modeline-field-function field) + buffer pane)) + (hi::buffer-modeline-fields buffer))))) + (send (%make-nsstring string) + :draw-at-point (ns-make-point 0.0f0 0.0f0) + :with-attributes *modeline-text-attributes*))))) + +;;; Draw the underlying buffer's modeline string on a white background +;;; with a bezeled border around it. +(define-objc-method ((:void :draw-rect (:ect rect)) + modeline-view) + (declare (ignore rect)) + (slet ((frame (send self 'bounds))) + (#_NSDrawWhiteBezel frame frame) + (draw-modeline-string self))) + +;;; Hook things up so that the modeline is updated whenever certain buffer +;;; attributes change. +(hi::%init-redisplay) + + + +;;; Modeline-scroll-view + +;;; This is just an NSScrollView that draws a "placard" view (the modeline) +;;; in the horizontal scrollbar. The modeline's arbitrarily given the +;;; leftmost 75% of the available real estate. +(defclass modeline-scroll-view (ns:ns-scroll-view) + ((modeline :foreign-type :id :accessor scroll-view-modeline) + (pane :foreign-type :id :accessor scroll-view-pane)) + (:metaclass ns:+ns-object)) + +;;; Making an instance of a modeline scroll view instantiates the +;;; modeline view, as well. + +(define-objc-method ((:id :init-with-frame (:ect frame)) + modeline-scroll-view) + (let* ((v (send-super :init-with-frame frame))) + (when v + (let* ((modeline (make-objc-instance 'modeline-view))) + (send v :add-subview modeline) + (setf (scroll-view-modeline v) modeline))) + v)) + +;;; Scroll views use the "tile" method to lay out their subviews. +;;; After the next-method has done so, steal some room in the horizontal +;;; scroll bar and place the modeline view there. + +(define-objc-method ((:void tile) modeline-scroll-view) + (send-super 'tile) + (let* ((modeline (scroll-view-modeline self))) + (when (and (send self 'has-horizontal-scroller) + (not (%null-ptr-p modeline))) + (let* ((hscroll (send self 'horizontal-scroller))) + (slet ((scrollbar-frame (send hscroll 'frame)) + (modeline-frame (send hscroll 'frame))) ; sic + (let* ((modeline-width (* (pref modeline-frame + :ect.size.width) + 0.75e0))) + (declare (single-float modeline-width)) + (setf (pref modeline-frame :ect.size.width) + modeline-width + (the single-float + (pref scrollbar-frame :ect.size.width)) + (- (the single-float + (pref scrollbar-frame :ect.size.width)) + modeline-width) + (the single-float + (pref scrollbar-frame :ect.origin.x)) + (+ (the single-float + (pref scrollbar-frame :ect.origin.x)) + modeline-width)) + (send hscroll :set-frame scrollbar-frame) + (send modeline :set-frame modeline-frame))))))) + + + +;;; Text-pane + +;;; The text pane is just an NSBox that (a) provides a draggable border +;;; around (b) encapsulates the text view and the mode line. + +(defclass text-pane (ns:ns-box) + ((text-view :foreign-type :id :accessor text-pane-text-view) + (mode-line :foreign-type :id :accessor text-pane-mode-line) + (scroll-view :foreign-type :id :accessor text-pane-scroll-view)) + (:metaclass ns:+ns-object)) + +;;; Mark the pane's modeline as needing display. This is called whenever +;;; "interesting" attributes of a buffer are changed. + +(defun hi::invalidate-modeline (pane) + (send (text-pane-mode-line pane) :set-needs-display t)) + +(define-objc-method ((:id :init-with-frame (:ect frame)) + text-pane) + (let* ((pane (send-super :init-with-frame frame))) + (unless (%null-ptr-p pane) + (send pane :set-autoresizing-mask (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (send pane :set-box-type #$NSBoxPrimary) + (send pane :set-border-type #$NSLineBorder) + (send pane :set-title-position #$NSNoTitle)) + pane)) + + +(defun make-scrolling-text-view-for-textstorage (textstorage x y width height) + (slet ((contentrect (ns-make-rect x y width height))) + (let* ((scrollview (send (make-objc-instance + 'modeline-scroll-view + :with-frame contentrect) 'autorelease))) + (send scrollview :set-border-type #$NSBezelBorder) + (send scrollview :set-has-vertical-scroller t) + (send scrollview :set-has-horizontal-scroller t) + (send scrollview :set-rulers-visible nil) + (send scrollview :set-autoresizing-mask (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (send (send scrollview 'content-view) :set-autoresizes-subviews t) + (let* ((layout (make-objc-instance 'ns-layout-manager))) + (send textstorage :add-layout-manager layout) + (send layout 'release) + (slet* ((contentsize (send scrollview 'content-size)) + (containersize (ns-make-size + 1.0f7 + 1.0f7)) + (tv-frame (ns-make-rect + 0.0f0 + 0.0f0 + (pref contentsize :ize.width) + (pref contentsize :ize.height)))) + (let* ((container (send (make-objc-instance + 'ns-text-container + :with-container-size containersize) + 'autorelease))) + (send layout :add-text-container container) + (let* ((tv (send (make-objc-instance 'hemlock-text-view + :with-frame tv-frame + :text-container container) + 'autorelease))) + (send tv :set-min-size (ns-make-size + 0.0f0 + (pref contentsize :ize.height))) + (send tv :set-max-size (ns-make-size 1.0f7 1.0f7)) + (send tv :set-rich-text nil) + (send tv :set-horizontally-resizable t) + (send tv :set-vertically-resizable t) + (send tv :set-autoresizing-mask #$NSViewWidthSizable) + (send container :set-width-tracks-text-view nil) + (send container :set-height-tracks-text-view nil) + (send scrollview :set-document-view tv) + (values tv scrollview)))))))) + +(defun make-scrolling-textview-for-pane (pane textstorage) + (slet ((contentrect (send (send pane 'content-view) 'frame))) + (multiple-value-bind (tv scrollview) + (make-scrolling-text-view-for-textstorage + textstorage + (pref contentrect :ect.origin.x) + (pref contentrect :ect.origin.y) + (pref contentrect :ect.size.width) + (pref contentrect :ect.size.height)) + (send pane :set-content-view scrollview) + (setf (slot-value pane 'scroll-view) scrollview + (slot-value pane 'text-view) tv + (slot-value tv 'pane) pane + (slot-value scrollview 'pane) pane) + (let* ((modeline (scroll-view-modeline scrollview))) + (setf (slot-value pane 'mode-line) modeline + (slot-value modeline 'pane) pane)) + tv))) + + +(defmethod hemlock-frame-command-info ((w ns:ns-window)) + nil) + + +(defclass hemlock-frame (ns:ns-window) + ((command-info :initform (hi::make-command-interpreter-info) + :accessor hemlock-frame-command-info)) + (:metaclass ns:+ns-object)) + + +(defmethod shared-initialize :after ((w hemlock-frame) + slot-names + &key &allow-other-keys) + (declare (ignore slot-names)) + (let ((info (hemlock-frame-command-info w))) + (when info + (setf (hi::command-interpreter-info-frame info) w)))) + + +(defun get-cocoa-window-flag (w flagname) + (case flagname + (:accepts-mouse-moved-events + (send w 'accepts-mouse-moved-events)) + (:cursor-rects-enabled + (send w 'are-cursor-rects-enabled)) + (:auto-display + (send w 'is-autodisplay)))) + + + +(defun (setf get-cocoa-window-flag) (value w flagname) + (case flagname + (:accepts-mouse-moved-events + (send w :set-accepts-mouse-moved-events value)) + (:auto-display + (send w :set-autodisplay value)))) + + + +(defun activate-window (w) + ;; Make w the "key" and frontmost window. Make it visible, if need be. + (send w :make-key-and-order-front nil)) + +(defun new-hemlock-document-window (&key + (x 200.0) + (y 200.0) + (height 200.0) + (width 500.0) + (closable t) + (iconifyable t) + (metal t) + (expandable t) + (backing :buffered) + (defer nil) + (accepts-mouse-moved-events nil) + (auto-display t) + (activate t)) + (rlet ((frame :ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height))) + (let* ((stylemask + (logior #$NSTitledWindowMask + (if closable #$NSClosableWindowMask 0) + (if iconifyable #$NSMiniaturizableWindowMask 0) + (if expandable #$NSResizableWindowMask 0) + (if metal #$NSTexturedBackgroundWindowMask 0))) + (backing-type + (ecase backing + ((t :retained) #$NSBackingStoreRetained) + ((nil :nonretained) #$NSBackingStoreNonretained) + (:buffered #$NSBackingStoreBuffered))) + (w (make-instance + 'hemlock-frame + :with-content-rect frame + :style-mask stylemask + :backing backing-type + :defer defer))) + (setf (get-cocoa-window-flag w :accepts-mouse-moved-events) + accepts-mouse-moved-events + (get-cocoa-window-flag w :auto-display) + auto-display) + (when activate (activate-window w)) + (values w (add-pane-to-window w :reserve-below 20.0))))) + + + +(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0)) + (let* ((window-content-view (send w 'content-view))) + (slet ((window-frame (send window-content-view 'frame))) + (slet ((pane-rect (ns-make-rect 0.0f0 + reserve-below + (pref window-frame :ect.size.width) + (- (pref window-frame :ect.size.height) (+ reserve-above reserve-below))))) + (let* ((pane (make-objc-instance 'text-pane :with-frame pane-rect))) + (send window-content-view :add-subview pane) + pane))))) + + + + + +(defun textpane-for-textstorage (ts) + (let* ((pane (nth-value + 1 + (new-hemlock-document-window :activate nil))) + (tv (make-scrolling-textview-for-pane pane ts))) + (multiple-value-bind (height width) + (size-of-char-in-font (default-font)) + (size-textview-containers tv height width 24 80)) + pane)) + + +(defun read-file-to-hemlock-buffer (path) + (hemlock::find-file-buffer path)) + +(defun hemlock-buffer-from-nsstring (nsstring name &rest modes) + (let* ((buffer (make-hemlock-buffer name :modes modes))) + (nsstring-to-buffer nsstring buffer))) + +(defun nsstring-to-buffer (nsstring buffer) + (let* ((document (hi::buffer-document buffer))) + (setf (hi::buffer-document buffer) nil) + (unwind-protect + (progn + (hi::delete-region (hi::buffer-region buffer)) + (hi::modifying-buffer buffer) + (hi::with-mark ((mark (hi::buffer-point buffer) :left-inserting)) + (let* ((string-len (send nsstring 'length)) + (line-start 0) + (first-line-terminator ()) + (first-line (hi::mark-line mark)) + (previous first-line) + (buffer (hi::line-%buffer first-line))) + (slet ((remaining-range (ns-make-range 0 1))) + (rlet ((line-end-index :unsigned) + (contents-end-index :unsigned)) + (do* ((number (+ (hi::line-number first-line) hi::line-increment) + (+ number hi::line-increment))) + ((= line-start string-len) + (let* ((line (hi::mark-line mark))) + (hi::insert-string mark (make-string 0)) + (setf (hi::line-next previous) line + (hi::line-previous line) previous)) + nil) + (setf (pref remaining-range :ange.location) line-start) + (send nsstring + :get-line-start (%null-ptr) + :end line-end-index + :contents-end contents-end-index + :for-range remaining-range) + (let* ((contents-end (pref contents-end-index :unsigned)) + (line-end (pref line-end-index :unsigned)) + (chars (make-string (- contents-end line-start)))) + (do* ((i line-start (1+ i)) + (j 0 (1+ j))) + ((= i contents-end)) + (setf (schar chars j) (code-char (send nsstring :character-at-index i)))) + (unless first-line-terminator + (let* ((terminator (code-char + (send nsstring :character-at-index + contents-end)))) + (setq first-line-terminator + (case terminator + (#\return (if (= line-end (+ contents-end 2)) + :cp/m + :macos)) + (t :unix))))) + (if (eq previous first-line) + (progn + (hi::insert-string mark chars) + (hi::insert-character mark #\newline) + (setq first-line nil)) + (if (eq string-len contents-end) + (hi::insert-string mark chars) + (let* ((line (hi::make-line + :previous previous + :%buffer buffer + :chars chars + :number number))) + (setf (hi::line-next previous) line) + (setq previous line)))) + (setq line-start line-end))))) + (when first-line-terminator + (setf (hi::buffer-external-format buffer) first-line-terminator)))) + (setf (hi::buffer-modified buffer) nil) + (hi::buffer-start (hi::buffer-point buffer)) + buffer) + (setf (hi::buffer-document buffer) document)))) + +(setq hi::*beep-function* #'(lambda (stream) + (declare (ignore stream)) + (#_NSBeep))) + + +;;; This function must run in the main event thread. +(defun %hemlock-frame-for-textstorage (ts title activate) + (let* ((pane (textpane-for-textstorage ts)) + (w (send pane 'window))) + (when title (send w :set-title (%make-nsstring title))) + (when activate (activate-window w)) + w)) + +(defun hemlock-frame-for-textstorage (ts title activate) + (process-interrupt *cocoa-event-process* + #'%hemlock-frame-for-textstorage + ts title activate)) + + +(defun for-each-textview-using-storage (textstorage f) + (let* ((layouts (send textstorage 'layout-managers))) + (unless (%null-ptr-p layouts) + (dotimes (i (send layouts 'count)) + (let* ((layout (send layouts :object-at-index i)) + (containers (send layout 'text-containers))) + (unless (%null-ptr-p containers) + (dotimes (j (send containers 'count)) + (let* ((container (send containers :object-at-index j)) + (tv (send container 'text-view))) + (funcall f tv))))))))) + + + +(defun hi::document-begin-editing (document) + (send (slot-value document 'textstorage) 'begin-editing)) + +(defun hi::document-end-editing (document) + (send (slot-value document 'textstorage) 'end-editing)) + +(defun hi::document-set-point-position (document) + (let* ((textstorage (slot-value document 'textstorage)) + (string (send textstorage 'string)) + (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string))) + (point (hi::buffer-point buffer)) + (pos (mark-absolute-position point))) + (for-each-textview-using-storage + textstorage + #'(lambda (tv) + (slet ((selection (ns-make-range pos 0))) + (send tv :set-selected-range selection) + (send tv :scroll-range-to-visible selection)))))) + + +(defun textstorage-note-insertion-at-position (textstorage pos n) + (send textstorage + :edited #$NSTextStorageEditedAttributes + :range (ns-make-range pos 0) + :change-in-length n) + (send textstorage + :edited #$NSTextStorageEditedCharacters + :range (ns-make-range pos n) + :change-in-length 0)) + +(defun hi::buffer-note-insertion (buffer mark n) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage)))) + (when textstorage + (let* ((pos (mark-absolute-position mark))) + (unless (eq (hi::mark-%kind mark) :right-inserting) + (decf pos n)) + #+debug 0 + (format t "~&pos = ~d, n = ~d" pos n) + (let* ((display (hemlock-buffer-string-cache (send textstorage 'string)))) + (reset-buffer-cache display) + (update-line-cache-for-index display pos)) + (textstorage-note-insertion-at-position textstorage pos n)))))) + + + +(defun hi::buffer-note-deletion (buffer mark n) + (when (hi::bufferp buffer) + (let* ((document (hi::buffer-document buffer)) + (textstorage (if document (slot-value document 'textstorage)))) + (when textstorage + (let* ((pos (mark-absolute-position mark))) + (setq n (abs n)) + (let* ((cache (hemlock-buffer-string-cache (send textstorage 'string)))) + (reset-buffer-cache cache) + (update-line-cache-for-index cache pos)) + + (send textstorage + :edited #$NSTextStorageEditedAttributes + :range (ns-make-range pos n) + :change-in-length (- n))))))) + +(defun hi::set-document-modified (document flag) + (send document + :update-change-count (if flag #$NSChangeDone #$NSChangeCleared))) + + +(defun hi::document-panes (document) + (let* ((ts (slot-value document 'textstorage)) + (panes ())) + (for-each-textview-using-storage + ts + #'(lambda (tv) + (let* ((pane (text-view-pane tv))) + (unless (%null-ptr-p pane) + (push pane panes))))) + panes)) + @@ -62,15 +984,4 @@ (send window :set-resize-increments (ns-make-size char-width char-height))))))) - -(defun info-from-document (doc) - (with-lock-grabbed (*open-editor-documents-lock*) - (find doc *open-editor-documents* :key #'cocoa-editor-info-document))) - -(defun info-from-controller (controller) - (with-lock-grabbed (*open-editor-documents-lock*) - (find controller *open-editor-documents* :key #'cocoa-editor-info-controller))) - - - @@ -96,10 +1007,9 @@ (let* ((doc (send-super 'init))) (unless (%null-ptr-p doc) - (let* ((buffer (hi::make-buffer + (let* ((buffer (make-hemlock-buffer (lisp-string-from-nsstring (send doc 'display-name)) :modes '("Lisp")))) (setf (slot-value doc 'textstorage) - (make-textstorage-for-hemlock-buffer - buffer) + (make-textstorage-for-hemlock-buffer buffer) (hi::buffer-document buffer) doc))) doc)) @@ -112,28 +1022,60 @@ (let* ((pathname (lisp-string-from-nsstring filename)) (buffer-name (hi::pathname-to-buffer-name pathname)) - (buffer (hi::make-buffer buffer-name)) + (buffer (or + (hemlock-document-buffer self) + (let* ((b (make-hemlock-buffer buffer-name))) + (setf (hi::buffer-pathname b) pathname) + (setf (slot-value self 'textstorage) + (make-textstorage-for-hemlock-buffer b)) + b))) (data (make-objc-instance 'ns:ns-data :with-contents-of-file filename)) (string (make-objc-instance 'ns:ns-string :with-data data - :encoding #$NSMacOSRomanStringEncoding))) - (setf (hi::buffer-pathname buffer) pathname) + :encoding #$NSASCIIStringEncoding))) + (hi::document-begin-editing self) (nsstring-to-buffer string buffer) - (hi::buffer-start (hi::buffer-point buffer)) + (let* ((textstorage (slot-value self 'textstorage)) + (display (hemlock-buffer-string-cache (send textstorage 'string)))) + (reset-buffer-cache display) + (update-line-cache-for-index display 0) + (textstorage-note-insertion-at-position + textstorage + 0 + (hemlock-buffer-length buffer))) + (hi::document-end-editing self) (setf (hi::buffer-modified buffer) nil) (hi::process-file-options buffer pathname) - (setf (slot-value self 'textstorage) - (make-textstorage-for-hemlock-buffer buffer) - (hi::buffer-document buffer) (%setf-macptr (%null-ptr) self)))) + self)) +(defmethod hemlock-document-buffer (document) + (let* ((string (send (slot-value document 'textstorage) 'string))) + (unless (%null-ptr-p string) + (let* ((cache (hemlock-buffer-string-cache string))) + (when cache (buffer-cache-buffer cache)))))) (define-objc-method ((:id :data-representation-of-type type) lisp-editor-document) (declare (ignorable type)) - (send (send (slot-value self 'text-view) 'string) + (let* ((buffer (hemlock-document-buffer self))) + (when buffer + (setf (hi::buffer-modified buffer) nil))) + (send (send (slot-value self 'textstorage) 'string) :data-using-encoding #$NSASCIIStringEncoding :allow-lossy-conversion t)) + +;;; Shadow the setFileName: method, so that we can keep the buffer +;;; name and pathname in synch with the document. +(define-objc-method ((:void :set-file-name full-path) + lisp-editor-document) + (send-super :set-file-name full-path) + (let* ((buffer (hemlock-document-buffer self))) + (when buffer + (let* ((new-pathname (lisp-string-from-nsstring full-path))) + (setf (hi::buffer-name buffer) (hi::pathname-to-buffer-name new-pathname)) + (setf (hi::buffer-pathname buffer) new-pathname))))) + (define-objc-method ((:void make-window-controllers) lisp-editor-document) (let* ((controller (make-objc-instance @@ -193,14 +1135,5 @@ (setf (slot-value self 'textstorage) (%null-ptr)) (unless (%null-ptr-p textstorage) - (close-hemlock-textstorage textstorage))) - (let* ((info (info-from-document self))) - (when info - (let* ((proc (cocoa-editor-info-listener info))) - (when proc - (setf (cocoa-editor-info-listener info) nil) - (process-kill proc))) - (with-lock-grabbed (*open-editor-documents-lock*) - (setq *open-editor-documents* - (delete info *open-editor-documents*)))))) + (close-hemlock-textstorage textstorage)))) Index: /trunk/ccl/examples/cocoa-listener.lisp =================================================================== --- /trunk/ccl/examples/cocoa-listener.lisp (revision 591) +++ /trunk/ccl/examples/cocoa-listener.lisp (revision 592) @@ -22,6 +22,8 @@ (type list *open-editor-documents*)) -#-hemlock -(progn + +(defloadvar *cocoa-listener-count* 0) + + (defun new-listener-process (procname input-fd output-fd) (make-mcl-listener-process @@ -38,10 +40,10 @@ #$_PC_MAX_INPUT)) #'(lambda () - (let* ((info (with-lock-grabbed (*open-editor-documents-lock*) - (find *current-process* *open-editor-documents* - :key #'cocoa-editor-info-listener)))) - (when info - (setf (cocoa-editor-info-listener info) nil) - (send (cocoa-editor-info-document info) + (let* ((buf (find *current-process* hi:*buffer-list* + :key #'hi::buffer-process)) + (doc (if buf (hi::buffer-document buf)))) + (when doc + (setf (hi::buffer-process buf) nil) + (send doc :perform-selector-on-main-thread (@selector "close") :with-object (%null-ptr) @@ -62,68 +64,44 @@ ((filehandle :foreign-type :id) ;Filehandle for I/O (clientfd :foreign-type :int) ;Client (listener)'s side of pty - (outpos :foreign-type :unsigned) ;Position in textview buffer - (userta :foreign-type :id) ;Typing attributes for user input - (systa :foreign-type :id) ;Typing attributes for system output - (usercolor :foreign-type :id) ;Text foreground color for user input ) (:metaclass ns:+ns-object) ) -(define-objc-method ((:void window-did-load) lisp-listener-window-controller) - (multiple-value-bind (server client) (ignore-errors (open-pty-pair)) - (when server - (let* ((fh (make-objc-instance - 'ns-file-handle - :with-file-descriptor (setup-server-pty server) - :close-on-dealloc t))) - (setf (slot-value self 'filehandle) fh) - (setf (slot-value self 'clientfd) (setup-client-pty client)) - (send (send (@class ns-notification-center) 'default-center) - :add-observer self - :selector (@selector "gotData:") - :name *NSFileHandleReadCompletionNotification* - :object fh) - (send fh 'read-in-background-and-notify))))) +(define-objc-method ((:id :init-with-window w) + lisp-listener-window-controller) + (let* ((self (send-super :init-with-window w))) + (unless (%null-ptr-p self) + (multiple-value-bind (server client) (ignore-errors (open-pty-pair)) + (when server + (let* ((fh (make-objc-instance + 'ns-file-handle + :with-file-descriptor (setup-server-pty server) + :close-on-dealloc t))) + (setf (slot-value self 'filehandle) fh) + (setf (slot-value self 'clientfd) (setup-client-pty client)) + (send (send (@class ns-notification-center) 'default-center) + :add-observer self + :selector (@selector "gotData:") + :name *NSFileHandleReadCompletionNotification* + :object fh) + (send fh 'read-in-background-and-notify))))) + self)) (define-objc-method ((:void :got-data notification) lisp-listener-window-controller) - (with-slots (filehandle systa outpos textview) self + (with-slots (filehandle) self (let* ((data (send (send notification 'user-info) :object-for-key *NSFileHandleNotificationDataItem*)) - (tv textview) + (document (send self 'document)) + (data-length (send data 'length)) + (buffer (hemlock-document-buffer document)) + (string (make-string data-length)) (fh filehandle)) - (unless (%null-ptr-p tv) - (let* ((buffer-text (send tv 'text-storage)) - (s (make-objc-instance 'ns-string - :with-data data - :encoding #$NSASCIIStringEncoding)) - (str (make-objc-instance 'ns-attributed-string - :with-string s - :attributes systa))) - (send buffer-text :append-attributed-string str) - - (let* ((textlen (send buffer-text 'length))) - (send tv :scroll-range-to-visible (ns-make-range textlen 0)) - (setq outpos textlen)) - (send str 'release))) - (send self 'update-package-name) + (declare (dynamic-extent string)) + (%copy-ptr-to-ivector (send data 'bytes) 0 string 0 data-length) + (hi::insert-string (hi::buffer-point buffer) string) (send fh 'read-in-background-and-notify)))) -(define-objc-method ((:void update-package-name) - lisp-listener-window-controller) - (let* ((info (info-from-controller self)) - (proc (if info (cocoa-editor-info-listener info))) - (package (if proc (ignore-errors (symbol-value-in-process - '*package* - proc)))) - (name (if (typep package 'package) - (shortest-package-name package) - ""))) - (with-cstrs ((name name)) - (send self :display-package-name (send (@class ns-string) - :string-with-c-string name))))) - - - +#| ;;; The Lisp-Listener-Window-Controller is the textview's "delegate": it ;;; gets consulted before certain actions are performed, and can @@ -142,5 +120,5 @@ (send tv :set-typing-attributes (slot-value self 'userta)) t))) - +|# ;;; Action methods implemented by the controller (in its role as the @@ -155,106 +133,7 @@ :allow-lossy-conversion t))) -(define-objc-method ((:void :insert-newline tv) - lisp-listener-window-controller) - (with-slots (outpos usercolor) self - (let* ((textbuf (send tv 'text-storage)) - (textlen (send textbuf 'length)) - (textstring (send tv 'string))) - (slet ((r (send tv 'selected-range))) - (let* ((curpos (pref r :ange.location)) - (curlen (pref r :ange.length))) - (cond ((>= curpos outpos) - ;; Insert the newline at the end of any selection. - (incf curpos (pref r :ange.length)) - (send tv :set-selected-range (ns-make-range curpos 0)) - (send tv :insert-newline self) - (incf curpos) - (incf textlen) - (when (= curpos textlen) - (let* ((sendlen (- textlen outpos)) - (sendstring - (send textstring - :substring-with-range (ns-make-range outpos sendlen)))) - (setf (pref r :ange.location) 0 - (pref r :ange.length) sendlen) - (multiple-value-bind (ok second-value) - (balanced-expressions-in-range-forward r sendstring) - (if ok - (if second-value - (progn - (send self :send-string sendstring) - (setq outPos textlen))) - (if second-value - (#_NSBeep))))))) - ;; If there's a selection, copy it to the end of the - ;; buffer, then move to the end of the buffer. - ((> curlen 0) - (slet ((endrange (ns-make-range textlen 0))) - (send tv :set-selected-range endrange) - (send tv :insert-text - (send textstring :substring-with-range r)) - (setf (pref endrange :ange.location) - (send textbuf 'length)) - (send tv :scroll-range-to-visible endrange))) - ;; No selection, insertion point is before outpos (in - ;; history or in output. If in history, copy history - ;; item to end of buffer, otherwise, do nothing. - (t - (rlet ((lr :ange) - (fullrange :ange :location 0 :length textlen)) - (let* ((attr - (send textbuf - :attribute #@"NSColor" - :at-index curpos - :longest-effective-range lr - :in-range fullrange))) - (when (send attr :is-equal usercolor) - (let* ((history-start (pref lr :ange.location)) - (history-len (pref lr :ange.length))) - (when (eql - (send textstring - :character-at-index - (+ history-start (1- history-len))) - (char-code #\NewLine)) - (decf (pref lr :ange.length))) - (unless (eql 0 history-len) - (setf (pref fullrange :ange.location) - textlen - (pref fullrange :ange.length) - 0) - (send tv :set-selected-range fullrange) - (send tv :insert-text - (send textstring :substring-with-range lr)) - (setf (pref fullrange :ange.location) - (send textbuf 'length)) - (send tv :scroll-range-to-visible fullrange))))))))))))) - -;;; Force a break in the listener process. -(define-objc-method ((:id :interrupt tv) lisp-listener-window-controller) - (declare (ignore tv)) - (let* ((info (info-from-controller self)) - (proc (if info (cocoa-editor-info-listener info)))) - (when proc (force-break-in-listener proc)) - self)) - -;;; This exists solely for debugging. -(define-objc-method ((:id :log-attrs tv) lisp-listener-window-controller) - (slet ((selection (send tv 'selected-range))) - (rlet ((lr :ange)) - (let* ((textbuf (send tv 'text-storage)) - (attr - (send textbuf - :attributes-at-index (pref selection :ange.location) - :longest-effective-range lr - :in-range (ns-make-range 0 (send textbuf 'length))))) - (#_NSLog #@"Attr = %@, range = [%d,%d]" - :address attr - :unsigned-fullword (pref lr :ange.location) - :unsigned-fullword (pref lr :ange.length))) - self))) - -;;; If we're at the end of the buffer and at the start of a line (either -;;; at outpos or after a newline), send an EOF (0 bytes of data) to the -;;; listener. Otherwise, have the textview do a "deleteForward:" + + + (define-objc-method ((:id :delete-forward tv) lisp-listener-window-controller) (with-slots (outpos filehandle) self @@ -279,14 +158,7 @@ self)))) -(define-objc-method ((:id :add-modeline tv) lisp-listener-window-controller) - (declare (ignore tv)) - self - ) - -(define-objc-method ((:id :reparse-modeline tv) - lisp-listener-window-controller) - (declare (ignore tv)) - self - ) + + + (define-objc-method ((:void dealloc) lisp-listener-window-controller) @@ -297,5 +169,4 @@ -) ;;; The LispListenerDocument class. @@ -305,6 +176,5 @@ (:metaclass ns:+ns-object)) -#-hemlock -(progn + (define-objc-class-method ((:id top-listener) lisp-listener-document) (let* ((all-documents (send *NSApp* 'ordered-Documents))) @@ -316,6 +186,7 @@ (defun symbol-value-in-top-listener-process (symbol) (let* ((listenerdoc (send (@class lisp-listener-document) 'top-listener)) - (info (info-from-document listenerdoc)) - (process (if info (cocoa-editor-info-listener info)))) + (buffer (unless (%null-ptr-p listenerdoc) + (hemlock-document-buffer listenerdoc))) + (process (if buffer (hi::buffer-process buffer)))) (if process (ignore-errors (symbol-value-in-process symbol process)) @@ -327,56 +198,36 @@ nil) -(define-objc-method ((:void make-window-controllers) lisp-listener-document) - (let* ((controller (make-objc-instance - 'lisp-listener-window-controller - :with-window-nib-name (send self 'window-nib-name) - :owner self))) - (send self :add-window-controller controller) - (send controller 'release))) - - - - - -(defloadvar *cocoa-listener-count* 17) - -(define-objc-method ((:void :window-controller-did-load-nib acontroller) + +(define-objc-method ((:id init) lisp-listener-document) - (send-super :window-controller-did-load-nib acontroller) - ;; We'll use attribute-change information to distinguish user - ;; input from system output. Be fascist about letting the - ;; user change anything. - (with-slots ((textview text-view) packagename echoarea filedata) self - (send textview :set-rich-text nil) - (send textview :set-uses-font-panel nil) - (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*)) + (let* ((doc (send-super 'init))) + (unless (%null-ptr-p doc) + (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*)) "Listener" (format nil "Listener-~d" *cocoa-listener-count*))) - (info (info-from-document self))) - (setf (cocoa-editor-info-listener info) - (let* ((tty (slot-value acontroller 'clientfd))) - (new-listener-process listener-name tty tty))) - (send self :set-file-name (%make-nsstring listener-name))) - (setf (slot-value acontroller 'textview) textview - (slot-value acontroller 'echoarea) echoarea - (slot-value acontroller 'packagename) packagename) - (let* ((userta (send (send textview 'typing-attributes) 'retain)) - (systa (create-text-attributes :color (send (@class ns-color) - 'blue-color)))) - (setf (slot-value acontroller 'userta) - userta - (slot-value acontroller 'usercolor) - (send userta :value-for-key #@"NSColor") - (slot-value acontroller 'systa) - systa)) - (send textview :set-delegate acontroller) - (unless (%null-ptr-p filedata) - (send textview - :replace-characters-in-range (ns-make-range 0 0) - :with-rtfd filedata)))) + (buffer (hemlock-document-buffer doc))) + (send doc :set-file-name (%make-nsstring listener-name)) + (setf (hi::buffer-pathname buffer) nil + (hi::buffer-minor-mode buffer "Listener") t + (hi::buffer-name buffer) listener-name))) + doc)) + +(define-objc-method ((:void make-window-controllers) lisp-listener-document) + (let* ((controller (make-objc-instance + 'lisp-listener-window-controller + :with-window (%hemlock-frame-for-textstorage + (slot-value self 'textstorage) nil nil))) + (listener-name (hi::buffer-name (hemlock-document-buffer self)))) + (send self :add-window-controller controller) + (send controller 'release) + (setf (hi::buffer-process (hemlock-document-buffer self)) + (let* ((tty (slot-value controller 'clientfd))) + (new-listener-process listener-name tty tty))) + controller)) ;;; This is almost completely wrong: we need to ensure that the form ;;; is read in the correct package, etc. +#| (defun send-to-top-listener (sender-info nsstring &optional (append-newline t)) (declare (ignorable sender-info)) @@ -391,5 +242,6 @@ " )))))) - - -); #-hemlock +|# + + +