Index: /trunk/ccl/examples/hemlock-textstorage.lisp =================================================================== --- /trunk/ccl/examples/hemlock-textstorage.lisp (revision 555) +++ /trunk/ccl/examples/hemlock-textstorage.lisp (revision 556) @@ -6,5 +6,4 @@ (use-interface-dir :cocoa)) -(defvar *buffer-id-map* (make-id-map)) (defstruct hemlock-display @@ -32,6 +31,7 @@ (defclass hemlock-buffer-string (ns:ns-string) - ((id :foreign-type :unsigned)) + ((display :initform nil :initarg :display :accessor hemlock-buffer-string-display)) (:metaclass ns:+ns-object)) + (defun update-line-cache-for-index (d index) @@ -85,11 +85,10 @@ hemlock-buffer-string) ;(#_NSLog #@"Character at index %d" :unsigned index ) - (char-code (hemlock-char-at-index - (id-map-object *buffer-id-map* (slot-value self 'id)) index))) + (char-code (hemlock-char-at-index (hemlock-buffer-string-display self) index))) (define-objc-method ((:unsigned length) hemlock-buffer-string) - (let* ((display-object (id-map-object *buffer-id-map* (slot-value self 'id)))) + (let* ((display-object (hemlock-buffer-string-display self))) (or (hemlock-display-buflen display-object) (setf (hemlock-display-buflen display-object) @@ -97,22 +96,12 @@ -(define-objc-method ((:unsigned lisp-id) - hemlock-buffer-string) - (slot-value self 'id)) (define-objc-method ((:id description) hemlock-buffer-string) - (send (@class ns-string) :string-with-format #@"%s : stringid %d/len %d" - (:address (#_object_getClassName self) - :unsigned (slot-value self 'id) - :unsigned (send self 'length)))) - -(define-objc-method ((:id :init-with-buffer-id (:unsigned n)) - hemlock-buffer-string) - (send-super 'init) - (setf (slot-value self 'id) n) - self) - - + (let* ((d (hemlock-buffer-string-display self)) + (b (hemlock-display-buffer d))) + (with-cstrs ((s (format nil "~a" b))) + (send (@class ns-string) :string-with-format #@"<%s for %s>" + (:address (#_object_getClassName self) :address s))))) @@ -122,5 +111,10 @@ (:metaclass ns:+ns-object)) - +(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)) + (define-objc-method ((:id string) lisp-text-storage) (slot-value self 'string)) @@ -131,5 +125,5 @@ '(#_NSLog #@"Attributes at index %d, rangeptr = %x" :unsigned index :address rangeptr) - (let* ((hemlock-display (id-map-object *buffer-id-map* (send (slot-value self 'string) 'lisp-id))) + (let* ((hemlock-display (hemlock-buffer-string-display (slot-value self 'string))) (len (hemlock-display-buflen hemlock-display))) (if (>= index len) @@ -164,31 +158,58 @@ :unsigned (pref r :ange.length))) -(define-objc-method ((:id :init-with-buffer-id (:unsigned buffer-id-number)) - lisp-text-storage) - (send-super 'init) - (with-slots (string defaultattrs) self - (setq string (make-objc-instance - 'hemlock-buffer-string - :with-buffer-id buffer-id-number)) - (setq defaultattrs (create-text-attributes))) - self) - - (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)))) + (:address (#_object_getClassName self) :id (slot-value self 'string)))) (defclass lisp-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)) (:metaclass ns:+ns-object)) +(defmethod text-view-buffer ((self lisp-text-view)) + (hemlock-display-buffer (hemlock-buffer-string-display (send (send self 'text-storage) 'string)))) + +;;; 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") + +(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))) + (dolist (map hemlock-ext::*modifier-translations*) + (when (logtest modifiers (car map)) + (setq bits (logior bits (hemlock-ext::key-event-modifier-mask + (cdr map)))))) + (hemlock-ext::make-key-event c bits))))) + + (define-objc-method ((:void :key-down event) lisp-text-view) - (#_NSLog #@"Key down event : %@" :address event) - (send-super :key-down event)) + (#_NSLog #@"Key down event = %@" :address event) + (format t "~& keycode = ~s~&" (send event 'key-code)) + (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)) + (hi::interpret-key-event key-event info)))))))) (define-objc-method ((:void :set-selected-range (:ange r) @@ -196,6 +217,5 @@ :still-selecting (: still-selecting)) lisp-text-view) - (let* ((d (id-map-object *buffer-id-map* - (send (send self 'string) 'lisp-id))) + (let* ((d (hemlock-buffer-string-display (send self 'string))) (point (hemlock::buffer-point (hemlock-display-buffer d))) (location (pref r :ange.location)) @@ -207,24 +227,29 @@ :still-selecting still-selecting))) - - -(define-objc-class-method ((:id :scrollview-with-rect (:ect contentrect) - :lisp-buffer-id (:unsigned stringid) - :horizontal-scroll-p (: hscroll-p)) - lisp-text-view) - (let* ((textstorage (make-objc-instance - 'lisp-text-storage - :with-buffer-id stringid)) - (scrollview - (send (make-objc-instance - 'ns-scroll-view - :with-frame contentrect) - 'autorelease))) + +(defun make-textstorage-for-hemlock-buffer (buffer) + (setf (hi::buffer-text-storage buffer) + (make-objc-instance 'lisp-text-storage + :with-string + (make-instance + 'hemlock-buffer-string + :display + (reset-display-cache + (make-hemlock-display) + buffer))))) + +(defun make-scrolling-text-view-for-buffer (buffer x y width height hscroll-p) + (slet ((contentrect (ns-make-rect x y width height))) + (let* ((textstorage (make-textstorage-for-hemlock-buffer buffer)) + (scrollview (send (make-objc-instance + 'ns-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 hscroll-p) (send scrollview :set-rulers-visible nil) - (send scrollview :set-autoresizing-mask (logior #$NSViewWidthSizable - #$NSViewHeightSizable)) + (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))) @@ -233,21 +258,20 @@ (slet* ((contentsize (send scrollview 'content-size)) (containersize (ns-make-size - 1.0f7 - 1.0f7)) + 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 + 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 - (send (send self 'alloc) - :init-with-frame tv-frame - :text-container container) - 'autorelease))) + (let* ((tv (send (make-objc-instance 'lisp-text-view + :with-frame tv-frame + :text-container container) + 'autorelease))) (send tv :set-min-size (ns-make-size 0.0f0 @@ -261,23 +285,38 @@ (send container :set-height-tracks-text-view nil) (send scrollview :set-document-view tv) - tv)))))) - - - -(define-objc-class-method ((:id :scrollview-for-window window - :buffer-id (:unsigned buffer-id) - :horizontal-scroll-p (: hscroll-p)) - lisp-text-view) - (let* ((contentview (send window 'content-view))) - (slet ((contentrect (send contentview 'frame))) - (let* ((tv (send - (@class lisp-text-view) - :scrollview-with-rect contentrect - :lisp-buffer-id buffer-id - :horizontal-scroll-p hscroll-p)) - (scrollview (send (send tv 'superview) 'superview))) - (send window :set-content-view scrollview) - tv)))) - + (values tv scrollview)))))))) + + +(defun make-scrolling-textview-for-view (superview buffer hscroll-p) + (slet ((contentrect (send (send superview 'content-view) 'frame))) + (multiple-value-bind (tv scrollview) + (make-scrolling-text-view-for-buffer + buffer + (pref contentrect :ect.origin.x) + (pref contentrect :ect.origin.y) + (pref contentrect :ect.size.width) + (pref contentrect :ect.size.height) + hscroll-p) + (send superview :set-content-view scrollview) + tv))) + +(defun make-scrolling-textview-for-window (&key window buffer hscroll-p) + (make-scrolling-textview-for-view (send window 'content-view) buffer hscroll-p)) + +(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) @@ -289,5 +328,5 @@ (:auto-display (send w 'is-autodisplay)))) - + (defun (setf get-cocoa-window-flag) (value w flagname) (case flagname @@ -301,19 +340,18 @@ (send w :make-key-and-order-front nil)) -(defun new-cocoa-document-window (title &key - (class-name "NSWindow") - (x 0.0) - (y 0.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)) +(defun new-hemlock-document-window (title &key + (x 0.0) + (y 0.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 @@ -328,6 +366,6 @@ ((nil :nonretained) #$NSBackingStoreNonretained) (:buffered #$NSBackingStoreBuffered))) - (w (make-objc-instance - class-name + (w (make-instance + 'hemlock-frame :with-content-rect frame :style-mask stylemask @@ -340,46 +378,121 @@ auto-display) (when activate (activate-window w)) - w))) - -(defun textview-for-buffer (id &key (horizontal-scroll-p t)) + (values w (add-box-to-window w :reserve-below 20.0))))) + +(defun add-box-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 ((box-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* ((box (make-objc-instance 'ns-box :with-frame box-rect))) + (send box :set-autoresizing-mask (logior + #$NSViewWidthSizable + #$NSViewHeightSizable)) + (send box :set-box-type #$NSBoxSecondary) + (send box :set-border-type #$NSLineBorder) + (send box :set-title-position #$NSBelowBottom) + (send window-content-view :add-subview box) + box))))) + + + +(defun textview-for-hemlock-buffer (b &key (horizontal-scroll-p t)) (process-interrupt *cocoa-event-process* #'(lambda () - (let* ((d (id-map-object *buffer-id-map* id)) - (name (hi::buffer-name (hemlock-display-buffer d))) - (w (new-cocoa-document-window name :activate nil)) - (tv - (send (@class lisp-text-view) - :scrollview-for-window w - :buffer-id id - :horizontal-scroll-p horizontal-scroll-p))) - (multiple-value-bind (height width) - (size-of-char-in-font (default-font)) - (size-textview-containers tv height width 24 80)) - (activate-window w) - tv)))) - -(defun put-textview-in-box (box) - (slet ((r (send (send box 'content-view) 'bounds))) - (let* ((sv (make-objc-instance 'ns-scroll-view :with-frame r)) - (sv-content-view (send sv 'content-view))) - (declare (ignorable sv-content-view)) - (send box :set-content-view sv) - (slet ((sv-content-size (send sv 'content-size))) - (slet ((tv-frame (ns-make-rect 0.0f0 0.0f0 - (pref sv-content-size :ize.width) - (pref sv-content-size :ize.height)))) - (let* ((tv (make-objc-instance 'ns-text-view - :with-frame tv-frame))) - (send sv :set-document-view tv) - (send box :set-content-view sv) - (values tv sv))))))) + (let* ((name (hi::buffer-name b))) + (multiple-value-bind (window box) + (new-hemlock-document-window name :activate nil) + (let* ((tv (make-scrolling-textview-for-view box + b + horizontal-scroll-p))) + (multiple-value-bind (height width) + (size-of-char-in-font (default-font)) + (size-textview-containers tv height width 24 80)) + (activate-window window) + tv)))))) + (defun read-file-to-hemlock-buffer (path) - (let* ((buffer (hemlock::find-file-buffer path))) - (reset-display-cache (make-hemlock-display) buffer))) - + (hemlock::find-file-buffer path)) + +(defun hemlock-buffer-from-nsstring (nsstring name) + (let* ((buffer (hi::make-buffer name))) + (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 (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)) + (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)) + (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)))) + (if (eq previous first-line) + (progn + (hi::insert-string mark chars) + (hi::insert-character mark #\newline) + (setq first-line nil)) + (if (eq (pref line-end-index :unsigned) string-len) + (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 (pref line-end-index :unsigned)))))))) + buffer)) + +(setq hi::*beep-function* #'(lambda (stream) + (declare (ignore stream)) + (#_NSBeep))) (defun edit (path) - (textview-for-buffer (assign-id-map-id *buffer-id-map* - (read-file-to-hemlock-buffer path)))) + (textview-for-hemlock-buffer (read-file-to-hemlock-buffer path))) + +(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::textstorage-set-point-position (textstorage) + (format t "~& setting point ...") + (let* ((string (send textstorage 'string)) + (buffer (hemlock-display-buffer (hemlock-buffer-string-display string))) + (point (hi::buffer-point buffer)) + (pos (mark-absolute-position point))) + (for-each-textview-using-storage + textstorage + #'(lambda (tv) + (send tv :set-selected-range (ns-make-range pos 0)))))) + + +