Changeset 7933

Timestamp:

Dec 23, 2007, 8:40:17 AM (17 years ago)

Author:

gz

Message:

Change scrolling interface: all actual scrolling now done by
hemlock-ext:scroll-view, invoked outside of document editing
context at the end of command handling.

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (4 diffs)
• hemlock/src/command.lisp (modified) (3 diffs)
• hemlock/src/package.lisp (modified) (2 diffs)
• hemlock/src/views.lisp (modified) (9 diffs)

branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

@@ -712 +712 @@
 (objc:defmethod (#/replaceCharactersInRange:withString: :void)
     ((self hemlock-text-storage) (r :<NSR>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 :<NSR>ange.location))
@@ -722 +720 @@
       (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 +2539 @@
   (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 :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
     (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>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 :<NSR>ange.location)
-              (pref char-range :<NSR>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 :<NSR>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 :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
+            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>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 +2767 @@
   (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*)))

branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

@@ -386 +386 @@
   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 +396 @@
   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 +406 @@
 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)))
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

@@ -351 +351 @@
    #: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 +444 @@
    #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed
    #:abort-to-toplevel #:abort-current-command
+   #:set-scroll-position
 
    ;; from line.lisp

branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

@@ -27 +27 @@
 (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 +65 @@
 
 (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 +85 @@
     (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 +96 @@
 ;; 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 +111 @@
   (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 +124 @@
   (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 +223 @@
     (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 +249 @@
       (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 +258 @@
                   (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))))))