Index: /trunk/ccl/examples/cocoa-editor.lisp =================================================================== --- /trunk/ccl/examples/cocoa-editor.lisp (revision 706) +++ /trunk/ccl/examples/cocoa-editor.lisp (revision 707) @@ -177,5 +177,6 @@ ;;; Ask Hemlock to count the characters in the buffer. (defun hemlock-buffer-length (buffer) - (hemlock::count-characters (hemlock::buffer-region buffer))) + (hi::with-buffer-gap-info (buffer) + (hemlock::count-characters (hemlock::buffer-region buffer)))) ;;; Find the line containing (or immediately preceding) index, which is @@ -183,15 +184,17 @@ ;;; 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)))) + (hi::with-buffer-gap-info ((buffer-cache-buffer cache)) + (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))) + (hi::with-buffer-gap-info ((buffer-cache-buffer cache)) + (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. @@ -199,9 +202,10 @@ ;;; 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)))))) + (hi::with-buffer-gap-info ((hi::line-%buffer (hi::mark-line mark))) + (let* ((pos (hi::mark-charpos mark))) + (do* ((line (hi::line-previous (hi::mark-line mark)) + (hi::line-previous line))) + ((null line) pos) + (incf pos (1+ (hi::line-length line))))))) ;;; Return the length of the abstract string, i.e., the number of @@ -212,5 +216,7 @@ (or (buffer-cache-buflen cache) (setf (buffer-cache-buflen cache) - (hemlock-buffer-length (buffer-cache-buffer cache)))))) + (let* ((buffer (buffer-cache-buffer cache))) + (hi::with-buffer-gap-info (buffer) + (hemlock-buffer-length buffer))))))) @@ -232,4 +238,5 @@ (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) @@ -282,6 +289,6 @@ -;;; Lisp-text-storage objects -(defclass lisp-text-storage (ns:ns-text-storage) +;;; hemlock-text-storage objects +(defclass hemlock-text-storage (ns:ns-text-storage) ((string :foreign-type :id)) (:metaclass ns:+ns-object)) @@ -289,8 +296,8 @@ ;;; 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) +(define-objc-method ((:id string) hemlock-text-storage) (slot-value self 'string)) -(define-objc-method ((:id :init-with-string s) lisp-text-storage) +(define-objc-method ((:id :init-with-string s) hemlock-text-storage) (let* ((newself (send-super 'init))) (setf (slot-value newself 'string) s) @@ -298,8 +305,8 @@ ;;; This is the only thing that's actually called to create a -;;; lisp-text-storage object. (It also creates the underlying +;;; hemlock-text-storage object. (It also creates the underlying ;;; hemlock-buffer-string.) (defun make-textstorage-for-hemlock-buffer (buffer) - (make-objc-instance 'lisp-text-storage + (make-objc-instance 'hemlock-text-storage :with-string (make-instance @@ -314,5 +321,5 @@ (define-objc-method ((:id :attributes-at-index (:unsigned index) :effective-range ((* :ange) rangeptr)) - lisp-text-storage) + hemlock-text-storage) (declare (ignorable index)) (let* ((buffer-cache (hemlock-buffer-string-cache (slot-value self 'string))) @@ -328,5 +335,5 @@ (define-objc-method ((:void :replace-characters-in-range (:ange r) :with-string string) - lisp-text-storage) + hemlock-text-storage) (#_NSLog #@"replace-characters-in-range (%d %d) with-string %@" :unsigned (pref r :ange.location) @@ -338,5 +345,5 @@ (define-objc-method ((:void :set-attributes attributes :range (:ange r)) - lisp-text-storage) + hemlock-text-storage) (#_NSLog #@"set-attributes %@ range (%d %d)" :id attributes @@ -344,10 +351,44 @@ :unsigned (pref r :ange.length))) +(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))))))))) ;;; Again, it's helpful to see the buffer name when debugging. (define-objc-method ((:id description) - lisp-text-storage) + hemlock-text-storage) (send (@class ns-string) :string-with-format #@"%s : string %@" (:address (#_object_getClassName self) :id (slot-value self 'string)))) + +;;; This needs to happen on the main thread. +(define-objc-method ((:void ensure-selection-visible) + hemlock-text-storage) + (for-each-textview-using-storage + self + #'(lambda (tv) + (send tv :scroll-range-to-visible (send tv 'selected-range))))) + +;;; This needs to run on the main thread. +(define-objc-method ((void update-hemlock-selection) + hemlock-text-storage) + (let* ((string (send self '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 + self + #'(lambda (tv) + (slet ((selection (ns-make-range pos 0))) + (send tv :set-selected-range selection)))))) + + (defun close-hemlock-textstorage (ts) @@ -418,25 +459,19 @@ (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) - (let* ((w (send self 'window)) - (hi::*echo-area-buffer* (hemlock-frame-echo-area-buffer w)) - (hi::*echo-area-stream* - (hemlock-frame-echo-area-stream w)) - (hi::*echo-area-window* (slot-value w 'echo-area-view )) - (hi::*echo-area-region* - (hi::buffer-region hi::*echo-area-buffer*))) - (hi::interpret-key-event key-event info))))))))) + (let* ((q (hemlock-frame-event-queue (send self 'window)))) + (hi::enqueue-key-event q (nsevent-to-key-event event))))) + ;; Probably not the right place for this, but needs to happen + ;; -somewhere-, and needs to happen in the event thread. + (send self :scroll-range-to-visible (send self 'selected-range)) + ) + +(defun enqueue-buffer-operation (buffer thunk) + (dolist (w (hi::buffer-windows buffer)) + (let* ((q (hemlock-frame-event-queue (send w 'window))) + (op (hi::make-buffer-operation :thunk thunk))) + (hi::enqueue-key-event q op)))) + -;;; Process a key-down NSEvent in a lisp text view by translating it +;;; Process a key-down NSEvent in a Hemlock 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 @@ -709,4 +744,7 @@ (send hemlock-frame :make-first-responder view))) +(defmethod text-view-buffer ((self echo-area-view)) + (buffer-cache-buffer (hemlock-buffer-string-cache (send (send self 'text-storage) 'string)))) + ;;; The "document" for an echo-area isn't a real NSDocument. (defclass echo-area-document (ns:ns-object) @@ -732,6 +770,4 @@ (incf *hemlock-frame-count*))) :modes '("Echo Area"))) - (stream (hi::make-hemlock-output-stream - (hi::region-end (hi::buffer-region buffer)) :full)) (textstorage (make-textstorage-for-hemlock-buffer buffer)) (doc (make-objc-instance 'echo-area-document)) @@ -756,5 +792,4 @@ (send container :set-height-tracks-text-view nil) (setf (hemlock-frame-echo-area-buffer hemlock-frame) buffer - (hemlock-frame-echo-area-stream hemlock-frame) stream (slot-value doc 'textstorage) textstorage (hi::buffer-document buffer) doc) @@ -769,31 +804,52 @@ echo-area)))) - -(defmethod hemlock-frame-command-info ((w ns:ns-window)) - nil) - - (defclass hemlock-frame (ns:ns-window) ((echo-area-view :foreign-type :id) - (command-info :initform (hi::make-command-interpreter-info) - :accessor hemlock-frame-command-info) + (event-queue :initform (ccl::init-dll-header (hi::make-frame-event-queue)) + :reader hemlock-frame-event-queue) + (command-thread :initform nil) (echo-area-buffer :initform nil :accessor hemlock-frame-echo-area-buffer) (echo-area-stream :initform nil :accessor hemlock-frame-echo-area-stream)) (: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 hemlock-thread-function (q buffer pane echo-buffer echo-window) + (let* ((hi::*real-editor-input* q) + (hi::*editor-input* q) + (hi::*current-buffer* hi::*current-buffer*) + (hi::*current-window* pane) + (hi::*echo-area-window* echo-window) + (hi::*echo-area-buffer* echo-buffer) + (region (hi::buffer-region echo-buffer)) + (hi::*echo-area-region* region) + (hi::*echo-area-stream* (hi::make-hemlock-output-stream + (hi::region-end region) :full)) + (hi::*cache-modification-tick* -1) + (hi::now-tick 0) + (hi::*disembodied-buffer-counter* 0) + (hi::*in-a-recursive-edit* nil) + (hi::*last-key-event-typed* nil) + (hi::*input-transcript* nil) + (hi::*line-cache-length* 200) + (hi::*open-line* nil) + (hi::*open-chars* (make-string hi::*line-cache-length* )) + (hi::*left-open-pos* 0) + (hi::*right-open-pos* 0) + (hemlock::*target-column* 0) + (hemlock::*last-comment-start* 0) + (hemlock::*last-search-string* ()) + (hemlock::*last-search-pattern* + (hemlock::new-search-pattern :string-insensitive :forward "Foo")) + ) + (setf (hi::current-buffer) buffer) + (hi::%command-loop))) + + +(define-objc-method ((:void close) hemlock-frame) + (let* ((proc (slot-value self 'command-thread))) + (when proc + (setf (slot-value self 'command-thread) nil) + (process-kill proc))) + (send-super 'close)) + (defun new-hemlock-document-window () (let* ((w (new-cocoa-window :class (find-class 'hemlock-frame) @@ -915,6 +971,19 @@ ;;; This function must run in the main event thread. (defun %hemlock-frame-for-textstorage (ts ncols nrows container-tracks-text-view-width) - (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width))) - (send pane 'window))) + (let* ((pane (textpane-for-textstorage ts ncols nrows container-tracks-text-view-width)) + (frame (send pane 'window)) + (buffer (text-view-buffer (text-pane-text-view pane)))) + (setf (slot-value frame 'command-thread) + (process-run-function (format nil "Hemlock window thread") + #'(lambda () + (hemlock-thread-function + (hemlock-frame-event-queue frame) + buffer + pane + (hemlock-frame-echo-area-buffer frame) + (slot-value frame 'echo-area-view))))) + frame)) + + @@ -925,40 +994,30 @@ -(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)) + (send (slot-value document 'textstorage) + :perform-selector-on-main-thread + (@selector "beginEditing") + :with-object (%null-ptr) + :wait-until-done t)) + + (defun hi::document-end-editing (document) + (send (slot-value document 'textstorage) + :perform-selector-on-main-thread + (@selector "endEditing") + :with-object (%null-ptr) + :wait-until-done t)) + +(defun hi::document-set-point-position (document) (let* ((textstorage (slot-value document 'textstorage))) - (send textstorage 'end-editing) - (for-each-textview-using-storage - textstorage - #'(lambda (tv) - (send tv :scroll-range-to-visible (send tv 'selected-range)))))) - -(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 textstorage + :perform-selector-on-main-thread + (@selector "updateHemlockSelection") + :with-object (%null-ptr) + :wait-until-done t))) @@ -1060,28 +1119,24 @@ -(defclass lisp-editor-window-controller (ns:ns-window-controller) +(defclass hemlock-editor-window-controller (ns:ns-window-controller) () (:metaclass ns:+ns-object)) -;;; The LispEditorWindowController is the textview's "delegate": it -;;; gets consulted before certain actions are performed, and can -;;; perform actions on behalf of the textview. - - - -;;; The LispEditorDocument class. - - -(defclass lisp-editor-document (ns:ns-document) + + +;;; The HemlockEditorDocument class. + + +(defclass hemlock-editor-document (ns:ns-document) ((textstorage :foreign-type :id)) (:metaclass ns:+ns-object)) -(define-objc-method ((:id init) lisp-editor-document) +(define-objc-method ((:id init) hemlock-editor-document) (let* ((doc (send-super 'init))) (unless (%null-ptr-p doc) (let* ((buffer (make-hemlock-buffer (lisp-string-from-nsstring (send doc 'display-name)) - :modes '("Lisp")))) + :modes '("Lisp" "Editor")))) (setf (slot-value doc 'textstorage) (make-textstorage-for-hemlock-buffer buffer) @@ -1092,5 +1147,5 @@ (define-objc-method ((:id :read-from-file filename :of-type type) - lisp-editor-document) + hemlock-editor-document) (declare (ignorable type)) (let* ((pathname (lisp-string-from-nsstring filename)) @@ -1130,5 +1185,5 @@ (when cache (buffer-cache-buffer cache)))))) -(defmethod hi::document-panes ((document lisp-editor-document)) +(defmethod hi::document-panes ((document hemlock-editor-document)) (let* ((ts (slot-value document 'textstorage)) (panes ())) @@ -1142,5 +1197,5 @@ (define-objc-method ((:id :data-representation-of-type type) - lisp-editor-document) + hemlock-editor-document) (declare (ignorable type)) (let* ((buffer (hemlock-document-buffer self))) @@ -1155,5 +1210,5 @@ ;;; name and pathname in synch with the document. (define-objc-method ((:void :set-file-name full-path) - lisp-editor-document) + hemlock-editor-document) (send-super :set-file-name full-path) (let* ((buffer (hemlock-document-buffer self))) @@ -1163,7 +1218,7 @@ (setf (hi::buffer-pathname buffer) new-pathname))))) -(define-objc-method ((:void make-window-controllers) lisp-editor-document) +(define-objc-method ((:void make-window-controllers) hemlock-editor-document) (let* ((controller (make-objc-instance - 'lisp-editor-window-controller + 'hemlock-editor-window-controller :with-window (%hemlock-frame-for-textstorage (slot-value self 'textstorage) @@ -1174,49 +1229,6 @@ (send controller 'release))) -#| -(define-objc-method ((:void :window-controller-did-load-nib acontroller) - lisp-editor-document) - (send-super :window-controller-did-load-nib acontroller) - ;; Apple/NeXT thinks that adding extra whitespace around cut & pasted - ;; text is "smart". Really, really smart insertion and deletion - ;; would alphabetize the selection for you (byChars: or byWords:); - ;; sadly, if you want that behavior you'll have to do it yourself. - ;; Likewise with the extra spaces. - (with-slots (text-view echoarea packagename filedata) self - (send text-view :set-alignment #$NSNaturalTextAlignment) - (send text-view :set-smart-insert-delete-enabled nil) - (send text-view :set-rich-text nil) - (send text-view :set-uses-font-panel t) - (send text-view :set-uses-ruler nil) - (with-lock-grabbed (*open-editor-documents-lock*) - (push (make-cocoa-editor-info - :document (%setf-macptr (%null-ptr) self) - :controller (%setf-macptr (%null-ptr) acontroller) - :listener nil) - *open-editor-documents*)) - (setf (slot-value acontroller 'textview) text-view - (slot-value acontroller 'echoarea) echoarea - (slot-value acontroller 'packagename) packagename) - (send text-view :set-delegate acontroller) - (let* ((font (default-font))) - (multiple-value-bind (height width) - (size-of-char-in-font font) - (size-textview-containers text-view height width 24 80)) - (send text-view - :set-typing-attributes - (create-text-attributes - :font font - :color (send (@class ns-color) 'black-color))) - (unless (%null-ptr-p filedata) - (send text-view - :replace-characters-in-range (ns-make-range 0 0) - :with-string (make-objc-instance - 'ns-string - :with-data filedata - :encoding #$NSASCIIStringEncoding)) -)))) -|# - -(define-objc-method ((:void close) lisp-editor-document) + +(define-objc-method ((:void close) hemlock-editor-document) (let* ((textstorage (slot-value self 'textstorage))) (setf (slot-value self 'textstorage) (%null-ptr)) @@ -1237,9 +1249,10 @@ (send textview :page-up nil))))) -(defun hi::get-key-event (text-view ignore) - (declare (ignore ignore)) - (let* ((event (send (send text-view 'window) - :next-event-matching-mask #$NSKeyDownMask))) - (nsevent-to-key-event event))) + +(defun hi::allocate-temporary-object-pool () + (create-autorelease-pool)) + +(defun hi::free-temporary-objects (pool) + (release-autorelease-pool pool)) (provide "COCOA-EDITOR")