Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7932) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7933) @@ -712,6 +712,4 @@ (objc:defmethod (#/replaceCharactersInRange:withString: :void) ((self hemlock-text-storage) (r :ange) string) - #+GZ (log-debug "~&replaceCharacters ts: ~s r: ~s s: ~s buf ~s frame: ~s" - self r string (hemlock-buffer self) (find (hemlock-buffer self) (windows) :key #'hemlock-buffer)) (let* ((buffer (hemlock-buffer self)) (position (pref r :ange.location)) @@ -722,6 +720,5 @@ (hi::handle-hemlock-event view #'(lambda () (hi:paste-characters position length - lisp-string))) - ))) + lisp-string)))))) (objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage) @@ -2542,85 +2539,76 @@ (call-next-method)) -(defun window-visible-range (text-view) - (let* ((rect (#/visibleRect text-view)) - (layout (#/layoutManager text-view)) - (text-container (#/textContainer text-view)) - (container-origin (#/textContainerOrigin text-view))) +(defmethod view-screen-lines ((view hi:hemlock-view)) + (let* ((pane (hi::hemlock-view-pane view))) + (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane))) + (text-view-char-height (text-pane-text-view pane))))) + +;; Beware this doesn't seem to take horizontal scrolling into account. +(defun visible-charpos-range (tv) + (let* ((rect (#/visibleRect tv)) + (container-origin (#/textContainerOrigin tv)) + (layout (#/layoutManager tv))) ;; Convert from view coordinates to container coordinates (decf (pref rect :ect.origin.x) (pref container-origin :oint.x)) (decf (pref rect :ect.origin.y) (pref container-origin :oint.y)) (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer: - layout rect text-container)) - (char-range (#/characterRangeForGlyphRange:actualGlyphRange: - layout glyph-range +null-ptr+))) + layout rect (#/textContainer tv))) + (char-range (#/characterRangeForGlyphRange:actualGlyphRange: + layout glyph-range +null-ptr+))) (values (pref char-range :ange.location) - (pref char-range :ange.length))))) - -(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) n) - (when n - (let* ((textpane (hi::hemlock-view-pane view)) - (sv (text-pane-scroll-view textpane)) - (tv (text-pane-text-view textpane)) - (char-height (text-view-char-height tv)) - (sv-height (ns:ns-size-height (#/contentSize sv))) - (nlines (floor sv-height char-height)) - (count (case n - (:page-up (- nlines)) - (:page-down nlines) - (t n)))) - (multiple-value-bind (pages lines) (floor (abs count) nlines) - (dotimes (i pages) - (if (< count 0) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - tv - (@selector #/scrollPageUp:) - +null-ptr+ - t) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - tv - (@selector #/scrollPageDown:) - +null-ptr+ - t))) - (dotimes (i lines) - (if (< count 0) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - tv - (@selector #/scrollLineUp:) - +null-ptr+ - t) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - tv - (@selector #/scrollLineDown:) - +null-ptr+ - t)))) - ;; If point is not on screen, move it. - (let* ((point (hi::current-point)) - (point-pos (hi:mark-absolute-position point))) - (multiple-value-bind (win-pos win-len) (window-visible-range tv) - (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len))) - (let* ((point (hi::current-point-collapsing-selection)) - (cache (hemlock-buffer-string-cache - (#/hemlockString (#/textStorage tv))))) - (move-hemlock-mark-to-absolute-position point cache win-pos) - ;; We should be done, but unfortunately, well, we're not. - ;; Something insists on recentering around point, so fake it out - #-work-around-overeager-centering - (or (hi::line-offset point (floor nlines 2)) - (if (< count 0) - (hi::buffer-start point) - (hi::buffer-end point)))))))))) - -(defmethod hemlock-ext:scroll-mark-to-top ((view hi:hemlock-view) mark) - "Make the position of MARK be on the first line displayed in the window" - (error "Not implemented yet")) - - -(defmethod hemlock-ext:center-selection-in-view ((view hi:hemlock-view)) - (#/performSelectorOnMainThread:withObject:waitUntilDone: - (text-pane-text-view (hi::hemlock-view-pane view)) - (@selector #/centerSelectionInVisibleArea:) - +null-ptr+ - t)) - + (pref char-range :ange.length))))) + +(defun charpos-xy (tv charpos) + (let* ((layout (#/layoutManager tv)) + (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange: + layout + (ns:make-ns-range charpos 0) + +null-ptr+)) + (rect (#/boundingRectForGlyphRange:inTextContainer: + layout + glyph-range + (#/textContainer tv))) + (container-origin (#/textContainerOrigin tv))) + (values (+ (pref rect :ect.origin.x) (pref container-origin :oint.x)) + (+ (pref rect :ect.origin.y) (pref container-origin :oint.y))))) + +(defun text-view-vscroll (tv) + ;; Return the number of pixels scrolled off the top of the view. I'm sure somewhere + ;; there is a cocoa functions that tells you just that, but I couldn't find it in + ;; the maze of twisty little views all alike and yet subtly different. + (nth-value 1 (charpos-xy tv (visible-charpos-range tv)))) + +(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where) + (assume-cocoa-thread) + (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view)))) + (ecase how + (:page-up + (require-type where 'null) + (#/scrollPageUp: tv +null-ptr+)) + (:page-down + (require-type where 'null) + (#/scrollPageDown: tv +null-ptr+)) + (:center-selection + (#/centerSelectionInVisibleArea: tv +null-ptr+)) + ((:lines-up :lines-down) + (setq where (require-type where 'integer)) + (when (< where 0) + (setq how (if (eq how :lines-up) :lines-down :lines-up) + where (- where))) + (multiple-value-bind (npages nlines) (floor where (view-screen-lines view)) + (dotimes (i npages) + (if (eq how :lines-up) + (#/scrollPageUp: tv +null-ptr+) + (#/scrollPageDown: tv +null-ptr+))) + (dotimes (i nlines) + (if (eq how :lines-up) + (#/scrollLineUp: tv +null-ptr+) + (#/scrollLineDown: tv +null-ptr+))))) + (:line + (setq where (require-type where '(integer 0))) + (let* ((line-y (nth-value 1 (charpos-xy tv where))) + (top-y (text-view-vscroll tv)) + (nlines (floor (- line-y top-y) (text-view-char-height tv)))) + (hemlock-ext:scroll-view view :lines-down nlines)))))) (defun iana-charset-name-of-nsstringencoding (ns) @@ -2779,4 +2767,5 @@ (let* ((pb (general-pasteboard)) (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType)))) + #+GZ (log-debug " string = ~s" string) (unless (%null-ptr-p string) (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7932) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7933) @@ -386,5 +386,7 @@ window, down one screenfull. If P is supplied then scroll that many lines." - (hemlock-ext:scroll-view view (or p :page-down))) + (if p + (set-scroll-position :lines-down p) + (set-scroll-position :page-down))) (defcommand "Scroll Window Up" (p &optional (view (current-view))) @@ -394,5 +396,7 @@ window, up one screenfull. If P is supplied then scroll that many lines." - (hemlock-ext:scroll-view view (if p (- p) :page-up))) + (if p + (set-scroll-position :lines-up p) + (set-scroll-position :page-up))) ;;;; Kind of miscellaneous commands: @@ -402,6 +406,6 @@ With prefix argument, puts moves current line to top of window" (if p - (hemlock-ext:scroll-mark-to-top (current-view) (current-point)) - (hemlock-ext:center-selection-in-view (current-view)))) + (set-scroll-position :line (current-point)) + (set-scroll-position :center-selection))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7932) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7933) @@ -351,9 +351,8 @@ #:default-directory - ;; defined externally (i.e. used by but not defined in hemlock) + ;; defined externally (i.e. used by but not defined in hemlock). These are the + ;; things that would need to be implemented to port to a different window system. #:invoke-modifying-buffer-storage #:note-selection-set-by-search - #:center-selection-in-view - #:scroll-mark-to-top #:scroll-view #:ensure-selection-visible @@ -445,4 +444,5 @@ #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed #:abort-to-toplevel #:abort-current-command + #:set-scroll-position ;; from line.lisp Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7932) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7933) @@ -27,5 +27,7 @@ (defvar *current-view* nil) -(defun current-view () *current-view*) +(defun current-view (&optional (must-exist t)) + (or *current-view* + (and must-exist (error "Hemlock view context not established")))) (defclass hemlock-view () @@ -63,15 +65,15 @@ (defun current-prefix-argument-state () - (hemlock-prefix-argument-state *current-view*)) + (hemlock-prefix-argument-state (current-view))) (defun last-key-event-typed () "This function returns the last key-event typed by the user and read as input." - (hemlock-last-key-event-typed *current-view*)) + (hemlock-last-key-event-typed (current-view))) (defun %set-last-key-event-typed (key) - (setf (hemlock-last-key-event-typed *current-view*) key)) + (setf (hemlock-last-key-event-typed (current-view)) key)) (defun last-char-typed () - (let ((key (hemlock-last-key-event-typed *current-view*))) + (let ((key (hemlock-last-key-event-typed (current-view)))) (when key (hemlock-ext:key-event-char key)))) @@ -83,5 +85,5 @@ (handler-case (progn - (hemlock-ext:report-hemlock-error *current-view* condition) + (hemlock-ext:report-hemlock-error (current-view) condition) (let ((emsg (ignore-errors (princ-to-string condition)))) (abort-to-toplevel (or emsg "Error")))) @@ -94,5 +96,5 @@ ;; This resets the command accumulation state in the current view. (defmethod reset-command-state () - (let ((view *current-view*)) + (let ((view (current-view))) ;; This resets c-q (setf (hemlock-view-quote-next-p view) nil) @@ -109,5 +111,5 @@ (reset-command-state) (invoke-hook hemlock::abort-hook) ;; reset ephemeral modes such as i-search. - (setf (hemlock-cancel-message *current-view*) message) + (setf (hemlock-cancel-message (current-view)) message) (let ((eps (current-echo-parse-state :must-exist nil))) (when eps @@ -122,5 +124,5 @@ (reset-command-state) (invoke-hook hemlock::abort-hook) - (setf (hemlock-cancel-message *current-view*) message) + (setf (hemlock-cancel-message (current-view)) message) (exit-event-handler)) @@ -221,4 +223,12 @@ (list* (buffer-signature buffer) start end))) +(defvar *next-view-start* nil) + +(defun set-scroll-position (how &optional where) + "Set the desired scroll position of the current view" + (when (markp where) + (setq where (mark-absolute-position where))) + (setf *next-view-start* (cons how where))) + (defmethod handle-hemlock-event ((view hemlock-view) key) ;; Key can also be a function, in which case it will get executed in the view event context @@ -239,4 +249,5 @@ (let* ((*current-view* view) (*current-buffer* (hemlock-view-current-buffer view)) + (*next-view-start* nil) ;; gets set by scrolling commands (text-buffer (hemlock-view-buffer view)) (mod (buffer-modification-state text-buffer))) @@ -247,7 +258,10 @@ (execute-hemlock-key view key)) (exit-event-handler () :report "Exit from hemlock event handler"))) - (unless (equal mod (buffer-modification-state text-buffer)) - ;; Modified buffer, make sure user sees what happened - (hemlock-ext:ensure-selection-visible view)) - (update-echo-area-after-command view) - ))))) + ;; Update display + (if *next-view-start* + (destructuring-bind (how . where) *next-view-start* + (hemlock-ext:scroll-view view how where)) + (unless (equal mod (buffer-modification-state text-buffer)) + ;; Modified buffer, make sure user sees what happened + (hemlock-ext:ensure-selection-visible view))) + (update-echo-area-after-command view))))))