Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7994) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7995) @@ -555,5 +555,5 @@ (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,5 +572,5 @@ (#/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,5 +1118,5 @@ ((pane :foreign-type :id :accessor text-view-pane) (char-width :foreign-type :loat :accessor text-view-char-width) - (char-height :foreign-type :loat :accessor text-view-char-height)) + (line-height :foreign-type :loat :accessor text-view-line-height)) (:metaclass ns:+ns-object)) (declaim (special hemlock-text-view)) @@ -1454,5 +1454,5 @@ ;;; 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,14 +1461,5 @@ (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,5 +2052,5 @@ font)))) -(defun buffer-active-font (buffer) +(defun buffer-active-font-attributes (buffer) (let* ((style 0) (region (hi::buffer-active-font-region buffer)) @@ -2137,7 +2128,7 @@ -(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,6 +2140,6 @@ 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,7 +2155,7 @@ (#/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,5 +2603,5 @@ (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,42 +2634,62 @@ (+ (pref rect :ect.origin.y) (pref container-origin :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) Index: /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7994) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-listener.lisp (revision 7995) @@ -67,8 +67,10 @@ (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,8 +132,7 @@ (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) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7994) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/main.lisp (revision 7995) @@ -90,6 +90,6 @@ (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,6 +107,6 @@ (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,6 +198,6 @@ :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*))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7994) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 7995) @@ -71,15 +71,14 @@ (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,8 +94,7 @@ (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,7 +109,6 @@ (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,7 +121,6 @@ (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,9 +130,8 @@ (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,9 +154,8 @@ (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,6 +196,5 @@ (make-modeline-field :name :process-info - :function #'(lambda (buffer window) - (declare (ignore window)) + :function #'(lambda (buffer) (hemlock-ext:buffer-process-description buffer)))