From 93404aaf3a6e0808ca17f1b1b91e6926bcc0f0a4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 15 May 2012 08:15:00 -0500 Subject: [PATCH] fix interaction between the framework's first-line-mixin and line-numbers mixin Specifically, when both are turned on, the #lang line now shows the line number and shifts the "#lang ..." over to the same spot where it is drawn when the first line is natually visible Also, rackety original commit: dfa0305bb3234808334607758f6ddceb32767824 --- collects/framework/private/text.rkt | 247 ++++++++++++++-------------- 1 file changed, 126 insertions(+), 121 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 8af8dc71..e2fa985c 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -571,7 +571,7 @@ (define first-line-mixin (mixin ((class->interface text%)) (first-line<%>) (inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location - scroll-to local-to-global get-dc) + scroll-to local-to-global get-dc get-padding) (define bx (box 0)) (define by (box 0)) (define bw (box 0)) @@ -659,80 +659,87 @@ [else (super on-event event)]))])) - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (unless before? (when (show-first-line?) - (let ([admin (get-admin)]) - (when admin - (send admin get-view bx by bw #f #f) - (unless (= (unbox by) 0) - (let ([first-line (get-text 0 (paragraph-end-position 0))] - [old-pen (send dc get-pen)] - [old-brush (send dc get-brush)] - [old-smoothing (send dc get-smoothing)] - [old-α (send dc get-alpha)] - [old-font (send dc get-font)] - [old-text-foreground (send dc get-text-foreground)] - [w-o-b? (preferences:get 'framework:white-on-black?)]) - (send dc set-font (get-font)) - (send dc set-smoothing 'aligned) - (let-values ([(tw th _1 _2) (send dc get-text-extent first-line)]) - (let ([line-height (+ (unbox by) dy th 1)] - [line-left (+ (unbox bx) dx)] - [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)) - (send dc draw-line line-left line-height line-right line-height) - - (when (eq? (send dc get-smoothing) 'aligned) - (let ([start (if w-o-b? 6/10 3/10)] - [end 0] - [steps 10]) - (send dc set-pen - (if w-o-b? dark-wob-first-line-color dark-first-line-color) - 1 - 'solid) - (let loop ([i steps]) - (unless (zero? i) - (let ([alpha-value (+ start (* (- end start) (/ i steps)))]) - (send dc set-alpha alpha-value) - (send dc draw-line - line-left - (+ line-height i) - line-right - (+ line-height i)) - (loop (- i 1)))))))) - - (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 set-text-foreground - (send the-color-database find-color - (if w-o-b? "white" "black"))) - (send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy))) - - (send dc set-text-foreground old-text-foreground) - (send dc set-font old-font) - (send dc set-pen old-pen) - (send dc set-brush old-brush) - (send dc set-alpha old-α) - (send dc set-smoothing old-smoothing))))))) + (define admin (get-admin)) + (when admin + (send admin get-view bx by bw #f #f) + (unless (= (unbox by) 0) + (define draw-first-line-number? + (and (is-a? this line-numbers<%>) + (send this showing-line-numbers?))) + (define first-line (get-text 0 (paragraph-end-position 0))) + (define old-pen (send dc get-pen)) + (define old-brush (send dc get-brush)) + (define old-smoothing (send dc get-smoothing)) + (define old-α (send dc get-alpha)) + (define old-font (send dc get-font)) + (define old-text-foreground (send dc get-text-foreground)) + (define w-o-b? (preferences:get 'framework:white-on-black?)) + (send dc set-font (get-font)) + (send dc set-smoothing 'aligned) + (define-values (tw th _1 _2) (send dc get-text-extent first-line)) + (define line-height (+ (unbox by) 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)) + (send dc draw-line line-left line-height line-right line-height) + + (when (eq? (send dc get-smoothing) 'aligned) + (define start (if w-o-b? 6/10 3/10)) + (define end 0) + (define steps 10) + (send dc set-pen + (if w-o-b? dark-wob-first-line-color dark-first-line-color) + 1 + 'solid) + (let loop ([i steps]) + (unless (zero? i) + (define alpha-value (+ start (* (- end start) (/ i steps)))) + (send dc set-alpha alpha-value) + (send dc draw-line + line-left + (+ line-height i) + line-right + (+ line-height i)) + (loop (- i 1))))) + + (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 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) + (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) + (define-values (padding-left padding-top padding-right padding-bottom) (get-padding)) + padding-left] + [else 0])) + (send dc draw-text first-line (+ x-start (+ (unbox bx) dx)) (+ (unbox by) dy)) + + (send dc set-text-foreground old-text-foreground) + (send dc set-font old-font) + (send dc set-pen old-pen) + (send dc set-brush old-brush) + (send dc set-alpha old-α) + (send dc set-smoothing old-smoothing))))) (super on-paint before? dc left top right bottom dx dy draw-caret)) (inherit get-style-list) (define/private (get-font) - (let* ([style-list (get-style-list)] - [std (or (send style-list find-named-style "Standard") - (send style-list basic-style))]) - (send std get-font))) + (define style-list (get-style-list)) + (define std (or (send style-list find-named-style "Standard") + (send style-list basic-style))) + (send std get-font)) (super-new))) @@ -3841,6 +3848,8 @@ designates the character that triggers autocompletion showing-line-numbers? set-line-numbers-color)) +(define-local-member-name do-draw-single-line draw-separator) + ;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) @@ -4026,37 +4035,36 @@ designates the character that triggers autocompletion (setup-padding)) (define/private (draw-numbers dc top bottom dx dy start-line end-line) - (define (draw-text . args) - (send/apply dc draw-text args)) - - (define right-space (text-width dc (number-space))) - (define single-space (text-width dc "0")) - (define last-paragraph #f) (for ([line (in-range start-line end-line)]) (define y (line-location line)) (define yb (line-location line #f)) - (when (and (y . <= . bottom) (yb . >= . top)) - (define view (number->string (add1 (line-paragraph line)))) - (define final-x - (+ (left-space dc dx) - (case alignment - [(left) 0] - [(right) (- right-space (text-width dc view) single-space)] - [else 0]))) - (define final-y (+ dy y)) - (if (and last-paragraph (= last-paragraph (line-paragraph line))) - (begin - (send dc set-text-foreground (lighter-color (send dc get-text-foreground))) - (draw-text view final-x final-y) - (send dc set-text-foreground (get-foreground))) - (draw-text view final-x final-y))) - + (do-draw-single-line dc dx dy line y last-paragraph)) (set! last-paragraph (line-paragraph line)))) + + (define/public (do-draw-single-line dc dx dy line y last-paragraph) + (define single-space (text-width dc "0")) + (define right-space (text-width dc (number-space))) + (define view (number->string (add1 (line-paragraph line)))) + (define final-x + (+ (left-space dc dx) + (case alignment + [(left) 0] + [(right) (- right-space (text-width dc view) single-space)] + [else 0]))) + (define final-y (+ dy y)) + (cond + [(and last-paragraph (= last-paragraph (line-paragraph line))) + (send dc set-text-foreground (lighter-color (send dc get-text-foreground))) + (send dc draw-text view final-x final-y) + (send dc set-text-foreground (get-foreground))] + [else + (send dc draw-text view final-x final-y)])) ;; draw the line between the line numbers and the actual text - (define/private (draw-separator dc top bottom dx dy x) + (define/public (draw-separator dc top bottom dx dy) + (define x (text-width dc (number-space))) (define line-x (+ (left-space dc dx) x)) (define line-y1 (+ dy top)) (define line-y2 (+ dy bottom)) @@ -4082,7 +4090,7 @@ designates the character that triggers autocompletion ; (printf "dx ~a\n" dx) ;; draw it! (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dx dy (text-width dc (number-space))) + (draw-separator dc top bottom dx dy) (restore-dc-state dc saved-dc)) (define/private (text-width dc stuff) @@ -4097,35 +4105,32 @@ designates the character that triggers autocompletion (define old-clipping #f) (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (if show-line-numbers? - (begin - (if before? - (let () - (define left-most (left-space dc dx)) - (set! old-clipping (send dc get-clipping-region)) - (define saved-dc (save-dc-state dc)) - (setup-dc dc) - (define clipped (make-object region% dc)) - (define all (make-object region% dc)) - (define copy (make-object region% dc)) - (send all set-rectangle - (+ dx left) (+ dy top) - (- right left) (- bottom top)) - (if old-clipping - (send copy union old-clipping) - (send copy union all)) - (send clipped set-rectangle - 0 (+ dy top) - (text-width dc (number-space+1)) - (- bottom top)) - (restore-dc-state dc saved-dc) - (send copy subtract clipped) - (send dc set-clipping-region copy)) - (begin - (send dc set-clipping-region old-clipping) - (draw-line-numbers dc left top right bottom dx dy)))) - (void)) - (void) + (when show-line-numbers? + (cond + [before? + (define left-most (left-space dc dx)) + (set! old-clipping (send dc get-clipping-region)) + (define saved-dc (save-dc-state dc)) + (setup-dc dc) + (define clipped (make-object region% dc)) + (define copy (make-object region% dc)) + (if old-clipping + (send copy union old-clipping) + (let ([all (make-object region% dc)]) + (send all set-rectangle + (+ dx left) (+ dy top) + (- right left) (- bottom top)) + (send copy union all))) + (send clipped set-rectangle + 0 (+ dy top) + (text-width dc (number-space+1)) + (- bottom top)) + (restore-dc-state dc saved-dc) + (send copy subtract clipped) + (send dc set-clipping-region copy)] + [else + (send dc set-clipping-region old-clipping) + (draw-line-numbers dc left top right bottom dx dy)])) (super on-paint before? dc left top right bottom dx dy draw-caret)) (super-new)