From fe77bb34d4e45589d303ae166730e6d0173ef4e8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 26 Nov 2015 08:46:38 -0600 Subject: [PATCH] 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 --- .../scribblings/gui/editor-canvas-class.scrbl | 17 ++++++- gui-doc/scribblings/gui/editor-intf.scrbl | 25 +++++++++ gui-lib/framework/private/text.rkt | 51 +++++++++++++++---- gui-lib/info.rkt | 2 +- gui-lib/mred/private/mrcanvas.rkt | 2 + gui-lib/mred/private/wxme/editor-canvas.rkt | 24 +++++++-- gui-lib/mred/private/wxme/editor.rkt | 5 ++ 7 files changed, 110 insertions(+), 16 deletions(-) diff --git a/gui-doc/scribblings/gui/editor-canvas-class.scrbl b/gui-doc/scribblings/gui/editor-canvas-class.scrbl index 4f9a64b5..cd1deeca 100644 --- a/gui-doc/scribblings/gui/editor-canvas-class.scrbl +++ b/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)]) diff --git a/gui-doc/scribblings/gui/editor-intf.scrbl b/gui-doc/scribblings/gui/editor-intf.scrbl index d0cb89cb..55319bf0 100644 --- a/gui-doc/scribblings/gui/editor-intf.scrbl +++ b/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%)] diff --git a/gui-lib/framework/private/text.rkt b/gui-lib/framework/private/text.rkt index d3c8c71a..d2cf2929 100644 --- a/gui-lib/framework/private/text.rkt +++ b/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%)) diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt index 7c43f50d..58e0ddd9 100644 --- a/gui-lib/info.rkt +++ b/gui-lib/info.rkt @@ -30,4 +30,4 @@ (define pkg-authors '(mflatt robby)) -(define version "1.18") +(define version "1.19") diff --git a/gui-lib/mred/private/mrcanvas.rkt b/gui-lib/mred/private/mrcanvas.rkt index 6d7ac188..3a7bd5a3 100644 --- a/gui-lib/mred/private/mrcanvas.rkt +++ b/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 diff --git a/gui-lib/mred/private/wxme/editor-canvas.rkt b/gui-lib/mred/private/wxme/editor-canvas.rkt index 60c9459d..a717c07d 100644 --- a/gui-lib/mred/private/wxme/editor-canvas.rkt +++ b/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)) diff --git a/gui-lib/mred/private/wxme/editor.rkt b/gui-lib/mred/private/wxme/editor.rkt index 8ecc38d3..fdd3823b 100644 --- a/gui-lib/mred/private/wxme/editor.rkt +++ b/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)