Changeset 7995

Timestamp:

Jan 3, 2008, 9:43:11 PM (17 years ago)

Author:

gz

Message:

More forceful stream-clear-input for listener input.

Do page/line scrolling using #/scrollToPoint.

Restore code to move point to be visible after scrolling commands.

Make modeline functions no longer take a "window" arg.

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (11 diffs)
• cocoa-listener.lisp (modified) (2 diffs)
• hemlock/src/main.lisp (modified) (3 diffs)
• hemlock/src/modeline.lisp (modified) (7 diffs)

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

@@ -555 +555 @@
          (buffer (buffer-cache-buffer display))
          (hi::*current-buffer* buffer)
-         (font (buffer-active-font buffer))
+         (attributes (buffer-active-font-attributes buffer))
          (document (#/document self))
          (undo-mgr (and document (#/undoManager document))))
@@ -572 +572 @@
          (#/prepareWithInvocationTarget: undo-mgr self)
          pos n #@"")))
-    (#/setAttributes:range: mirror font (ns:make-ns-range pos n))    
+    (#/setAttributes:range: mirror attributes (ns:make-ns-range pos n))
     (textstorage-note-insertion-at-position self pos n)))
 
@@ -1118 +1118 @@
     ((pane :foreign-type :id :accessor text-view-pane)
      (char-width :foreign-type :<CGF>loat :accessor text-view-char-width)
-     (char-height :foreign-type :<CGF>loat :accessor text-view-char-height))
+     (line-height :foreign-type :<CGF>loat :accessor text-view-line-height))
   (:metaclass ns:+ns-object))
 (declaim (special hemlock-text-view))
@@ -1454 +1454 @@
 ;;; used in the event dispatch mechanism,
 (defun draw-modeline-string (the-modeline-view)
-  (with-slots (pane text-attributes) the-modeline-view
+  (with-slots (text-attributes) the-modeline-view
     (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
       (when buffer
@@ -1461 +1461 @@
                        (mapcar
                         #'(lambda (field)
-                            #+GZ (or (ignore-errors (funcall (hi::modeline-field-function field)
-                                                             buffer pane))
-                                     (format nil "#<~s ~s>" (hi::modeline-field-name field)
-                                             (and (eq (hi::modeline-field-name field) :package)
-                                                  (hi::variable-value 'hemlock::current-package
-                                                                      :buffer buffer))))
-
-                            #-GZ
-                            (funcall (hi::modeline-field-function field)
-                                     buffer pane))
+                            (funcall (hi::modeline-field-function field) buffer))
                         (hi::buffer-modeline-fields buffer)))))
           (#/drawAtPoint:withAttributes: (%make-nsstring string)
@@ -2061 +2052 @@
                                         font))))
 
-(defun buffer-active-font (buffer)
+(defun buffer-active-font-attributes (buffer)
   (let* ((style 0)
          (region (hi::buffer-active-font-region buffer))
@@ -2137 +2128 @@
 
 
-(defun size-text-pane (pane char-height char-width nrows ncols)
+(defun size-text-pane (pane line-height char-width nrows ncols)
   (let* ((tv (text-pane-text-view pane))
-         (height (fceiling (* nrows char-height)))
+         (height (fceiling (* nrows line-height)))
          (width (fceiling (* ncols char-width)))
          (scrollview (text-pane-scroll-view pane))
@@ -2149 +2140 @@
                       height)
       (when has-vertical-scroller 
-        (#/setVerticalLineScroll: scrollview char-height)
-        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|char-height|#))
+        (#/setVerticalLineScroll: scrollview line-height)
+        (#/setVerticalPageScroll: scrollview (cgfloat 0.0) #|line-height|#))
       (when has-horizontal-scroller
         (#/setHorizontalLineScroll: scrollview char-width)
@@ -2164 +2155 @@
         (#/setContentSize: window sv-size)
         (setf (slot-value tv 'char-width) char-width
-              (slot-value tv 'char-height) char-height)
+              (slot-value tv 'line-height) line-height)
         (#/setResizeIncrements: window
-                                (ns:make-ns-size char-width char-height))))))
+                                (ns:make-ns-size char-width line-height))))))
                                     
   
@@ -2612 +2603 @@
     (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)))))
+             (text-view-line-height (text-pane-text-view pane)))))
 
 ;; Beware this doesn't seem to take horizontal scrolling into account.
@@ -2643 +2634 @@
             (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
 
+;;(nth-value 1 (charpos-xy tv (visible-charpos-range tv))) - this is smaller as it
+;; only includes lines fully scrolled off...
 (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))))
+  ;; Return the number of pixels scrolled off the top of the view.
+  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
+         (clip-view (#/contentView scroll-view))
+         (bounds (#/bounds clip-view)))
+    (ns:ns-rect-y bounds)))
+
+(defun set-text-view-vscroll (tv vscroll)
+  (let* ((scroll-view (text-pane-scroll-view (text-view-pane tv)))
+         (clip-view (#/contentView scroll-view))
+         (bounds (#/bounds clip-view)))
+    (decf vscroll (mod vscroll (text-view-line-height tv))) ;; show whole line
+    (ns:with-ns-point (new-origin (ns:ns-rect-x bounds) vscroll)
+      (#/scrollToPoint: clip-view (#/constrainScrollPoint: clip-view new-origin))
+      (#/reflectScrolledClipView: scroll-view clip-view))))
+
+(defun scroll-by-lines (tv nlines)
+  "Change the vertical origin of the containing scrollview's clipview"
+  (set-text-view-vscroll tv (+ (text-view-vscroll tv)
+                               (* nlines (text-view-line-height tv)))))
+
+;; TODO: should be a hemlock variable..
+(defvar *next-screen-context-lines* 2)
 
 (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))))
+    (when (eq how :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-line-height tv))))
+        (setq how :lines-down where nlines)))
     (ecase how
+      (:center-selection
+       (#/centerSelectionInVisibleArea: tv +null-ptr+))
       (:page-up
        (require-type where 'null)
-       (#/scrollPageUp: tv +null-ptr+))
+       ;; TODO: next-screen-context-lines
+       (scroll-by-lines tv (- *next-screen-context-lines* (view-screen-lines view))))
       (: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))))))
+       (scroll-by-lines tv (- (view-screen-lines view) *next-screen-context-lines*)))
+      (:lines-up
+       (scroll-by-lines tv (- (require-type where 'integer))))
+      (:lines-down
+       (scroll-by-lines tv (require-type where 'integer))))
+    ;; 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) (visible-charpos-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)
+            (update-hemlock-selection (#/textStorage tv))))))))
 
 (defun iana-charset-name-of-nsstringencoding (ns)

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

@@ -67 +67 @@
       (loop
         (when cur-sstream
+          #+gz (log-debug "About to recursively read from sstring in env: ~s" cur-env)
           (let* ((env cur-env)
                  (form (progv (car env) (cdr env)
                          (ccl::read-toplevel-form cur-sstream eof-value)))
                  (last-form-in-selection (not (listen cur-sstream))))
+            #+gz (log-debug " --> ~s" form)
             (when last-form-in-selection
               (setf cur-sstream nil cur-env nil))
@@ -130 +132 @@
 
 (defmethod stream-clear-input ((stream cocoa-listener-input-stream))
-  (with-slots (queue-lock cur-string cur-string-pos) stream
+  (with-slots (queue-lock cur-string cur-string-pos cur-sstream cur-env) stream
     (with-lock-grabbed (queue-lock)
-      (setf cur-string nil cur-string-pos 0))))
-
+      (setf cur-string nil cur-string-pos 0 cur-sstream nil cur-env nil))))
 
 (defparameter $listener-flush-limit 100)

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

@@ -90 +90 @@
 (make-modeline-field
  :name :edit-level :width 15
- :function #'(lambda (buffer window)
-               (declare (ignore buffer window))
+ :function #'(lambda (buffer)
+               (declare (ignore buffer))
                (if (zerop hemlock::*recursive-edit-count*)
                    ""
@@ -107 +107 @@
 (make-modeline-field
  :name :completion :width 40
- :function #'(lambda (buffer window)
-               (declare (ignore buffer window))
+ :function #'(lambda (buffer)
+               (declare (ignore buffer))
                hemlock::*completion-mode-possibility*))
 
@@ -198 +198 @@
     :value (list (make-modeline-field
                   :name :hemlock-banner :width 27
-                  :function #'(lambda (buffer window)
-                                (declare (ignore buffer window))
+                  :function #'(lambda (buffer)
+                                (declare (ignore buffer))
                                 (format nil "Hemlock ~A  "
                                         *hemlock-version*)))

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

@@ -71 +71 @@
 
 (make-modeline-field :name :hemlock-literal :width 8
-                     :function #'(lambda (buffer window)
+                     :function #'(lambda (buffer)
                                    "Returns \"Hemlock \"."
-                                   (declare (ignore buffer window))
+                                   (declare (ignore buffer))
                                    "Hemlock "))
 
 (make-modeline-field
  :name :external-format
- :function #'(lambda (buffer window)
+ :function #'(lambda (buffer)
                "Returns an indication of buffer's external-format, iff it's
 other than :DEFAULT"
-               (declare (ignore window))
                (let* ((line-termination-string
                        (case (buffer-line-termination buffer)
@@ -95 +94 @@
 (make-modeline-field
  :name :package
- :function #'(lambda (buffer window)
+ :function #'(lambda (buffer)
                "Returns the value of buffer's \"Current Package\" followed
                 by a colon and two spaces, or a string with one space."
-               (declare (ignore window))
                (if (hemlock-bound-p 'hemlock::current-package :buffer buffer)
                    (let ((val (variable-value 'hemlock::current-package
@@ -111 +109 @@
 (make-modeline-field
  :name :modes
- :function #'(lambda (buffer window)
+ :function #'(lambda (buffer)
                "Returns buffer's modes followed by one space."
-               (declare (ignore window))
                (let* ((m ()))
                  (dolist (mode (buffer-mode-objects buffer))
@@ -124 +121 @@
 (make-modeline-field
  :name :modifiedp
- :function #'(lambda (buffer window)
+ :function #'(lambda (buffer)
                "Returns \"* \" if buffer is modified, or \"  \"."
-               (declare (ignore window))
                (let ((modifiedp (buffer-modified buffer)))
                  (if modifiedp
@@ -134 +130 @@
 (make-modeline-field
  :name :buffer-name
- :function #'(lambda (buffer window)
+ :function #'(lambda (buffer)
                "Returns buffer's name followed by a colon and a space if the
                 name is not derived from the buffer's pathname, or the empty
                 string."
-               (declare (ignore window))
                (let ((pn (buffer-pathname buffer))
                      (name (buffer-name buffer)))
@@ -159 +154 @@
         (note-modeline-change buffer)))))
 
-(defun buffer-pathname-ml-field-fun (buffer window)
+(defun buffer-pathname-ml-field-fun (buffer)
   "Returns the namestring of buffer's pathname if there is one.  When
    \"Maximum Modeline Pathname Length\" is set, and the namestring is too long,
    return a truncated namestring chopping off leading directory specifications."
-  (declare (ignore window))
   (let ((pn (buffer-pathname buffer)))
     (if pn
@@ -202 +196 @@
 (make-modeline-field
  :name :process-info
- :function #'(lambda (buffer window)
-               (declare (ignore window))
+ :function #'(lambda (buffer)
                (hemlock-ext:buffer-process-description buffer)))