Changeset 7933


Ignore:
Timestamp:
Dec 23, 2007, 4:40:17 PM (12 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:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7929 r7933  
    712712(objc:defmethod (#/replaceCharactersInRange:withString: :void)
    713713    ((self hemlock-text-storage) (r :<NSR>ange) string)
    714   #+GZ (log-debug "~&replaceCharacters ts: ~s r: ~s s: ~s buf ~s frame: ~s"
    715                    self r string (hemlock-buffer self) (find (hemlock-buffer self) (windows) :key #'hemlock-buffer))
    716714  (let* ((buffer (hemlock-buffer self))
    717715         (position (pref r :<NSR>ange.location))
     
    722720      (hi::handle-hemlock-event view #'(lambda ()
    723721                                         (hi:paste-characters position length
    724                                                               lisp-string)))
    725       )))
     722                                                              lisp-string))))))
    726723
    727724(objc:defmethod (#/setAttributes:range: :void) ((self hemlock-text-storage)
     
    25422539  (call-next-method))
    25432540
    2544 (defun window-visible-range (text-view)
    2545   (let* ((rect (#/visibleRect text-view))
    2546          (layout (#/layoutManager text-view))
    2547          (text-container (#/textContainer text-view))
    2548          (container-origin (#/textContainerOrigin text-view)))
     2541(defmethod view-screen-lines ((view hi:hemlock-view))
     2542    (let* ((pane (hi::hemlock-view-pane view)))
     2543      (floor (ns:ns-size-height (#/contentSize (text-pane-scroll-view pane)))
     2544             (text-view-char-height (text-pane-text-view pane)))))
     2545
     2546;; Beware this doesn't seem to take horizontal scrolling into account.
     2547(defun visible-charpos-range (tv)
     2548  (let* ((rect (#/visibleRect tv))
     2549         (container-origin (#/textContainerOrigin tv))
     2550         (layout (#/layoutManager tv)))
    25492551    ;; Convert from view coordinates to container coordinates
    25502552    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
    25512553    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
    25522554    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
    2553                          layout rect text-container))
    2554            (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
    2555                         layout glyph-range +null-ptr+)))
     2555                         layout rect (#/textContainer tv)))
     2556           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
     2557                        layout glyph-range +null-ptr+)))
    25562558      (values (pref char-range :<NSR>ange.location)
    2557               (pref char-range :<NSR>ange.length)))))
    2558    
    2559 (defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) n)
    2560   (when n
    2561     (let* ((textpane (hi::hemlock-view-pane view))
    2562            (sv (text-pane-scroll-view textpane))
    2563            (tv (text-pane-text-view textpane))
    2564            (char-height (text-view-char-height tv))
    2565            (sv-height (ns:ns-size-height (#/contentSize sv)))
    2566            (nlines (floor sv-height char-height))
    2567            (count (case n
    2568                     (:page-up (- nlines))
    2569                     (:page-down nlines)
    2570                     (t n))))
    2571       (multiple-value-bind (pages lines) (floor (abs count) nlines)
    2572         (dotimes (i pages)
    2573           (if (< count 0)
    2574               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2575                tv
    2576                (@selector #/scrollPageUp:)
    2577                +null-ptr+
    2578                t)
    2579               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2580                tv
    2581                (@selector #/scrollPageDown:)
    2582                +null-ptr+
    2583                t)))
    2584         (dotimes (i lines)
    2585           (if (< count 0)
    2586               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2587                tv
    2588                (@selector #/scrollLineUp:)
    2589                +null-ptr+
    2590                t)
    2591               (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2592                tv
    2593                (@selector #/scrollLineDown:)
    2594                +null-ptr+
    2595                t))))
    2596       ;; If point is not on screen, move it.
    2597       (let* ((point (hi::current-point))
    2598              (point-pos (hi:mark-absolute-position point)))
    2599         (multiple-value-bind (win-pos win-len) (window-visible-range tv)
    2600           (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
    2601             (let* ((point (hi::current-point-collapsing-selection))
    2602                    (cache (hemlock-buffer-string-cache
    2603                            (#/hemlockString (#/textStorage tv)))))
    2604               (move-hemlock-mark-to-absolute-position point cache win-pos)
    2605               ;; We should be done, but unfortunately, well, we're not.
    2606               ;; Something insists on recentering around point, so fake it out
    2607               #-work-around-overeager-centering
    2608               (or (hi::line-offset point (floor nlines 2))
    2609                   (if (< count 0)
    2610                       (hi::buffer-start point)
    2611                       (hi::buffer-end point))))))))))
    2612 
    2613 (defmethod hemlock-ext:scroll-mark-to-top ((view hi:hemlock-view) mark)
    2614   "Make the position of MARK be on the first line displayed in the window"
    2615   (error "Not implemented yet"))
    2616 
    2617 
    2618 (defmethod hemlock-ext:center-selection-in-view ((view hi:hemlock-view))
    2619   (#/performSelectorOnMainThread:withObject:waitUntilDone:
    2620    (text-pane-text-view (hi::hemlock-view-pane view))
    2621    (@selector #/centerSelectionInVisibleArea:)
    2622    +null-ptr+
    2623    t))
    2624 
     2559              (pref char-range :<NSR>ange.length)))))
     2560
     2561(defun charpos-xy (tv charpos)
     2562  (let* ((layout (#/layoutManager tv))
     2563         (glyph-range (#/glyphRangeForCharacterRange:actualCharacterRange:
     2564                       layout
     2565                       (ns:make-ns-range charpos 0)
     2566                       +null-ptr+))
     2567         (rect (#/boundingRectForGlyphRange:inTextContainer:
     2568                layout
     2569                glyph-range
     2570                (#/textContainer tv)))
     2571         (container-origin (#/textContainerOrigin tv)))
     2572    (values (+ (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
     2573            (+ (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y)))))
     2574
     2575(defun text-view-vscroll (tv)
     2576  ;; Return the number of pixels scrolled off the top of the view.  I'm sure somewhere
     2577  ;; there is a cocoa functions that tells you just that, but I couldn't find it in
     2578  ;; the maze of twisty little views all alike and yet subtly different.
     2579  (nth-value 1 (charpos-xy tv (visible-charpos-range tv))))
     2580
     2581(defmethod hemlock-ext:scroll-view ((view hi:hemlock-view) how &optional where)
     2582  (assume-cocoa-thread)
     2583  (let* ((tv (text-pane-text-view (hi::hemlock-view-pane view))))
     2584    (ecase how
     2585      (:page-up
     2586       (require-type where 'null)
     2587       (#/scrollPageUp: tv +null-ptr+))
     2588      (:page-down
     2589       (require-type where 'null)
     2590       (#/scrollPageDown: tv +null-ptr+))
     2591      (:center-selection
     2592       (#/centerSelectionInVisibleArea: tv +null-ptr+))
     2593      ((:lines-up :lines-down)
     2594       (setq where (require-type where 'integer))
     2595       (when (< where 0)
     2596         (setq how (if (eq how :lines-up) :lines-down :lines-up)
     2597               where (- where)))
     2598       (multiple-value-bind (npages nlines) (floor where (view-screen-lines view))
     2599         (dotimes (i npages)
     2600           (if (eq how :lines-up)
     2601             (#/scrollPageUp: tv +null-ptr+)
     2602             (#/scrollPageDown: tv +null-ptr+)))
     2603         (dotimes (i nlines)
     2604           (if (eq how :lines-up)
     2605             (#/scrollLineUp: tv +null-ptr+)
     2606             (#/scrollLineDown: tv +null-ptr+)))))
     2607      (:line
     2608       (setq where (require-type where '(integer 0)))
     2609       (let* ((line-y (nth-value 1 (charpos-xy tv where)))
     2610              (top-y (text-view-vscroll tv))
     2611              (nlines (floor (- line-y top-y) (text-view-char-height tv))))
     2612         (hemlock-ext:scroll-view view :lines-down nlines))))))
    26252613
    26262614(defun iana-charset-name-of-nsstringencoding (ns)
     
    27792767  (let* ((pb (general-pasteboard))
    27802768         (string (progn (#/types pb) (#/stringForType: pb #&NSStringPboardType))))
     2769    #+GZ (log-debug "   string = ~s" string)
    27812770    (unless (%null-ptr-p string)
    27822771      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

    r7932 r7933  
    386386  window, down one screenfull.  If P is supplied then scroll that
    387387  many lines."
    388   (hemlock-ext:scroll-view view (or p :page-down)))
     388  (if p
     389    (set-scroll-position :lines-down p)
     390    (set-scroll-position :page-down)))
    389391
    390392(defcommand "Scroll Window Up" (p &optional (view (current-view)))
     
    394396  window, up one screenfull.  If P is supplied then scroll that
    395397  many lines."
    396   (hemlock-ext:scroll-view view (if p (- p) :page-up)))
     398  (if p
     399    (set-scroll-position :lines-up p)
     400    (set-scroll-position :page-up)))
    397401
    398402;;;; Kind of miscellaneous commands:
     
    402406With prefix argument, puts moves current line to top of window"
    403407  (if p
    404     (hemlock-ext:scroll-mark-to-top (current-view) (current-point))
    405     (hemlock-ext:center-selection-in-view (current-view))))
     408    (set-scroll-position :line (current-point))
     409    (set-scroll-position :center-selection)))
    406410
    407411
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7929 r7933  
    351351   #:default-directory
    352352
    353    ;; defined externally (i.e. used by but not defined in hemlock)
     353   ;; defined externally (i.e. used by but not defined in hemlock).  These are the
     354   ;; things that would need to be implemented to port to a different window system.
    354355   #:invoke-modifying-buffer-storage
    355356   #:note-selection-set-by-search
    356    #:center-selection-in-view
    357    #:scroll-mark-to-top
    358357   #:scroll-view
    359358   #:ensure-selection-visible
     
    445444   #:current-prefix-argument-state #:last-key-event-typed #:last-char-typed
    446445   #:abort-to-toplevel #:abort-current-command
     446   #:set-scroll-position
    447447
    448448   ;; from line.lisp
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7929 r7933  
    2727(defvar *current-view* nil)
    2828
    29 (defun current-view () *current-view*)
     29(defun current-view (&optional (must-exist t))
     30  (or *current-view*
     31      (and must-exist (error "Hemlock view context not established"))))
    3032
    3133(defclass hemlock-view ()
     
    6365
    6466(defun current-prefix-argument-state ()
    65   (hemlock-prefix-argument-state *current-view*))
     67  (hemlock-prefix-argument-state (current-view)))
    6668
    6769(defun last-key-event-typed ()
    6870  "This function returns the last key-event typed by the user and read as input."
    69   (hemlock-last-key-event-typed *current-view*))
     71  (hemlock-last-key-event-typed (current-view)))
    7072
    7173(defun %set-last-key-event-typed (key)
    72   (setf (hemlock-last-key-event-typed *current-view*) key))
     74  (setf (hemlock-last-key-event-typed (current-view)) key))
    7375
    7476(defun last-char-typed ()
    75   (let ((key (hemlock-last-key-event-typed *current-view*)))
     77  (let ((key (hemlock-last-key-event-typed (current-view))))
    7678    (when key (hemlock-ext:key-event-char key))))
    7779
     
    8385    (handler-case
    8486        (progn
    85           (hemlock-ext:report-hemlock-error *current-view* condition)
     87          (hemlock-ext:report-hemlock-error (current-view) condition)
    8688          (let ((emsg (ignore-errors (princ-to-string condition))))
    8789            (abort-to-toplevel (or emsg "Error"))))
     
    9496;; This resets the command accumulation state in the current view.
    9597(defmethod reset-command-state ()
    96   (let ((view *current-view*))
     98  (let ((view (current-view)))
    9799    ;; This resets c-q
    98100    (setf (hemlock-view-quote-next-p view) nil)
     
    109111  (reset-command-state)
    110112  (invoke-hook hemlock::abort-hook) ;; reset ephemeral modes such as i-search.
    111   (setf (hemlock-cancel-message *current-view*) message)
     113  (setf (hemlock-cancel-message (current-view)) message)
    112114  (let ((eps (current-echo-parse-state :must-exist nil)))
    113115    (when eps
     
    122124  (reset-command-state)
    123125  (invoke-hook hemlock::abort-hook)
    124   (setf (hemlock-cancel-message *current-view*) message)
     126  (setf (hemlock-cancel-message (current-view)) message)
    125127  (exit-event-handler))
    126128
     
    221223    (list* (buffer-signature buffer) start end)))
    222224
     225(defvar *next-view-start* nil)
     226
     227(defun set-scroll-position (how &optional where)
     228  "Set the desired scroll position of the current view"
     229  (when (markp where)
     230    (setq where (mark-absolute-position where)))
     231  (setf *next-view-start* (cons how where)))
     232
    223233(defmethod handle-hemlock-event ((view hemlock-view) key)
    224234  ;; Key can also be a function, in which case it will get executed in the view event context
     
    239249      (let* ((*current-view* view)
    240250             (*current-buffer* (hemlock-view-current-buffer view))
     251             (*next-view-start* nil) ;; gets set by scrolling commands
    241252             (text-buffer (hemlock-view-buffer view))
    242253             (mod (buffer-modification-state text-buffer)))
     
    247258                  (execute-hemlock-key view key))
    248259              (exit-event-handler () :report "Exit from hemlock event handler")))
    249           (unless (equal mod (buffer-modification-state text-buffer))
    250             ;; Modified buffer, make sure user sees what happened
    251             (hemlock-ext:ensure-selection-visible view))
    252           (update-echo-area-after-command view)
    253           )))))
     260          ;; Update display
     261          (if *next-view-start*
     262            (destructuring-bind (how . where) *next-view-start*
     263              (hemlock-ext:scroll-view view how where))
     264            (unless (equal mod (buffer-modification-state text-buffer))
     265              ;; Modified buffer, make sure user sees what happened
     266              (hemlock-ext:ensure-selection-visible view)))
     267          (update-echo-area-after-command view))))))
Note: See TracChangeset for help on using the changeset viewer.