more on scroll-by-copy

make it per-editor customizable, add callbacks, and use
them to make the special first line mixin work properly
when it is enabled

gui-doc/scribblings/gui/editor-canvas-class.scrbl

@@ -183,6 +183,17 @@ Returns a line count installed with @method[editor-canvas%
 
 }
 
+@defmethod[(get-scroll-via-copy) boolean?]{
+  Returns @racket[#t] if scrolling triggers a copy of
+  the editor content (and then a refresh of the newly exposed
+  content). Returns @racket[#f] when scrolling triggers a
+  refresh of the entire editor canvas. Defaults to
+  @racket[#f].
+
+  See also @method[editor<%> on-scroll-to]
+  and @method[editor<%> after-scroll-to].
+}
+
 @defmethod*[([(horizontal-inset)
               (integer-in 1 10000)]
              [(horizontal-inset [step (integer-in 1 10000)])
@@ -324,7 +335,7 @@ Enables or disables bottom-base scrolling, or gets the current enable
 }
 
 
-
+                      
 @defmethod[(set-editor [edit (or/c (or/c (is-a?/c text%) (is-a?/c pasteboard%)) #f)]
                        [redraw? any/c #t])
            void?]{
@@ -360,6 +371,10 @@ If the line count is set to @racket[#f], then the canvas's graphical
 }
 
 
+@defmethod[(set-scroll-via-copy [scroll-via-copy? any/c]) void?]{
+  Changes the scrolling mode refresh. See also @method[editor-canvas% get-scroll-via-copy].
+}
+
 @defmethod*[([(vertical-inset)
               (integer-in 1 10000)]
              [(vertical-inset [step (integer-in 1 10000)])

gui-doc/scribblings/gui/editor-intf.scrbl

@@ -164,6 +164,20 @@ Does nothing.
 }
 }
 
+ @defmethod[(after-scroll-to) void?]{
+  @methspec{
+   Called when the editor has just scrolled, but the entire display
+   may not have been refreshed. (If the editor scrolls but the entire window
+   is redrawn, this method may not be called.)
+   
+   See also @method[editor-canvas% get-scroll-via-copy].
+  }
+
+  @methimpl{Does nothing.}
+ }
+
+
+                 
 @defmethod*[([(auto-wrap)
               boolean?]
              [(auto-wrap [auto-wrap? any/c])
@@ -1656,6 +1670,17 @@ Does nothing.
 
 }}
 
+ @defmethod[(on-scroll-to) void?]{
+  @methspec{
+   Called when the editor is about to scroll, but the entire display is
+   may not be refreshed. (If the editor scrolls but the entire window
+   is redrawn, this method may not be called.)
+   
+   See also @method[editor-canvas% get-scroll-via-copy].
+  }
+
+  @methimpl{Does nothing.}
+ }
 
 @defmethod[#:mode pubment 
            (on-snip-modified [snip (is-a?/c snip%)]

gui-lib/framework/private/text.rkt

@@ -748,6 +748,38 @@
               (super on-event event)]
              [else         
               (super on-event event)]))]))
+
+    (define to-invalidate #f)
+    (define/override (on-scroll-to)
+      (super on-scroll-to)
+      (set! to-invalidate (get-region-to-draw)))
+    (define/override (after-scroll-to)
+      (super after-scroll-to)
+      (define (maybe-invalidate)
+        (when to-invalidate
+          (invalidate-bitmap-cache
+           (list-ref to-invalidate 0)
+           (list-ref to-invalidate 1)
+           (list-ref to-invalidate 2)
+           (list-ref to-invalidate 3))
+          (set! to-invalidate #f)))
+      (maybe-invalidate)
+      (set! to-invalidate (get-region-to-draw))
+      (maybe-invalidate))
+    (define/private (get-region-to-draw)
+      (cond
+        [(show-first-line?)
+         (define admin (get-admin))
+         (cond
+           [admin
+            (send admin get-view bx by bw #f #f)
+            (define first-line (get-text 0 (paragraph-end-position 0)))
+            (define-values (tw th _1 _2) (send (get-dc) get-text-extent first-line (get-font)))
+            (list (unbox bx) (unbox by) (unbox bw) (+ th extra-fade-space))]
+           [else #f])]
+        [else #f]))
+
+    (define extra-fade-space 11)
     
     (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
       (unless before?
@@ -755,7 +787,8 @@
           (define admin (get-admin))
           (when admin
             (send admin get-view bx by bw #f #f)
-            (unless (= (unbox by) 0)
+            (define y-coord (unbox by))
+            (unless (= y-coord 0)
               (define draw-first-line-number?
                 (and (is-a? this line-numbers<%>)
                      (send this showing-line-numbers?)))
@@ -772,10 +805,10 @@
               (send dc set-smoothing 'aligned)
               (send dc set-text-mode 'transparent)
               (define-values (tw th _1 _2) (send dc get-text-extent first-line))
-              (define line-height (+ (unbox by) dy th 1))
+              (define line-height (+ y-coord dy th 1))
               (define line-left (+ (unbox bx) dx))
               (define line-right (+ (unbox bx) dx (unbox bw)))
-              
+
               (if w-o-b?
                   (send dc set-pen "white" 1 'solid)
                   (send dc set-pen "black" 1 'solid))
@@ -784,7 +817,7 @@
               (when (eq? (send dc get-smoothing) 'aligned)
                 (define start (if w-o-b? 6/10 3/10))
                 (define end 0)
-                (define steps 10)
+                (define steps (- extra-fade-space 1))
                 (send dc set-pen 
                       (if w-o-b? dark-wob-first-line-color dark-first-line-color) 
                       1
@@ -803,20 +836,20 @@
               (send dc set-alpha 1)
               (send dc set-pen "gray" 1 'transparent)
               (send dc set-brush (if w-o-b? "black" "white") 'solid)
-              (send dc draw-rectangle (+ (unbox bx) dx) (+ (unbox by) dy) (unbox bw) th)
+              (send dc draw-rectangle (+ (unbox bx) dx) (+ y-coord dy) (unbox bw) th)
               (send dc set-text-foreground
                     (send the-color-database find-color
                           (if w-o-b? "white" "black")))
               (define x-start
                 (cond
                   [draw-first-line-number?
-                   (send this do-draw-single-line dc dx dy 0 (unbox by) #f #f)
+                   (send this do-draw-single-line dc dx dy 0 y-coord #f #f)
                    (send dc set-pen (if w-o-b? "white" "black") 1 'solid)
-                   (send this draw-separator dc (unbox by) (+ (unbox by) line-height) dx dy)
+                   (send this draw-separator dc y-coord (+ y-coord line-height) dx dy)
                    (define-values (padding-left _1 _2 _3) (get-padding))
                    padding-left]
                   [else 0]))
-              (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ (unbox by) dy))
+              (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ y-coord dy))
               
               (send dc set-text-foreground old-text-foreground)
               (send dc set-text-mode old-text-mode)
@@ -4570,7 +4603,7 @@ designates the character that triggers autocompletion
      #t)
      
     (super-new)))
-  
+
 (define basic% (basic-mixin (editor:basic-mixin text%)))
 (define line-spacing% (line-spacing-mixin basic%))
 (define hide-caret/selection% (hide-caret/selection-mixin line-spacing%))

gui-lib/info.rkt

@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.18")
+(define version "1.19")

gui-lib/mred/private/mrcanvas.rkt

@@ -320,6 +320,8 @@
     (define scroll-to-last? #f)
     (define scroll-bottom? #f)
     (define/public (call-as-primary-owner f) (send wx call-as-primary-owner f))
+    (define/public (set-scroll-via-copy s) (send wx set-scroll-via-copy s))
+    (define/public (get-scroll-via-copy) (send wx get-scroll-via-copy))
     (define allow-scroll-to-last
       (entry-point 
        (case-lambda

gui-lib/mred/private/wxme/editor-canvas.rkt

@@ -157,8 +157,6 @@
 
 (define (keep-style l s) (if (memq s l) (list s) null))
 
-(define SCROLL-VIA-COPY? #f)
-
 (defclass editor-canvas% canvas%
 
   (inherit refresh get-canvas-background get-dc
@@ -172,6 +170,10 @@
            begin-refresh-sequence
            end-refresh-sequence)
 
+  (define scroll-via-copy? #f)
+  (define/public (set-scroll-via-copy v) (set! scroll-via-copy? (and v #t)))
+  (define/public (get-scroll-via-copy) scroll-via-copy?)
+
   (define blink-timer #f)
   (define noloop? #f)
 
@@ -944,11 +946,13 @@
                     retval)))))))
 
   (define/private (do-scroll x y refresh? old-x old-y)
+    (define ed (get-editor))
     (let ([savenoloop? noloop?])
       (set! noloop? #t)
       
       (maybe-reset-size)
-
+      (define on-scroll-to-called? #f)
+      
       (define change?
         (or
          ;; Set x
@@ -958,6 +962,9 @@
                 (and (not (= x old-x))
                      (begin
                        (when (not fake-x-scroll?)
+                         (when scroll-via-copy?
+                           (set! on-scroll-to-called? #t)
+                           (when scroll-via-copy? (when ed (send ed on-scroll-to))))
                          (set-scroll-pos 'horizontal x))
                        #t))))
          ;; Set y
@@ -967,13 +974,17 @@
                 (and (not (= y old-y))
                      (begin
                        (when (not fake-y-scroll?)
+                         (unless on-scroll-to-called?
+                           (when scroll-via-copy?
+                             (set! on-scroll-to-called? #t)
+                             (when ed (send ed on-scroll-to))))
                          (set-scroll-pos 'vertical y))
                        #t))))))
       
       (set! noloop? savenoloop?)
 
       (when (and change? refresh?)
-        (if (and SCROLL-VIA-COPY?
+        (if (and scroll-via-copy?
                  (not need-refresh?)
                  (not lazy-refresh?)
                  (get-canvas-background)
@@ -1016,7 +1027,10 @@
                               #t))
                     (end-refresh-sequence))]
                  [else (repaint)])))
-            (repaint)))))
+            (repaint)))
+
+      (when on-scroll-to-called?
+        (when ed (send ed after-scroll-to)))))
 
   (define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void))
 

gui-lib/mred/private/wxme/editor.rkt

@@ -226,6 +226,11 @@
 
   ;; ----------------------------------------
 
+  (define/public (on-scroll-to) (void))
+  (define/public (after-scroll-to) (void))
+  
+  ;; ----------------------------------------
+
   (def/public (set-admin [(make-or-false editor-admin%) administrator])
     (setting-admin administrator)