suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix interaction between the framework's first-line-mixin and

Browse Source 
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
This commit is contained in:
Robby Findler 2012-05-15 08:15:00 -05:00
parent eea4d30f1b
commit 93404aaf3a
1 changed files with 126 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
collects/framework/private/text.rkt
View File

@ -571,7 +571,7 @@
(define first-line-mixin (define first-line-mixin
(mixin ((class->interface text%)) (first-line<%>) (mixin ((class->interface text%)) (first-line<%>)
(inherit get-text paragraph-end-position get-admin invalidate-bitmap-cache position-location (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 bx (box 0))
(define by (box 0)) (define by (box 0))
(define bw (box 0)) (define bw (box 0))
@ -659,80 +659,87 @@
[else [else
(super on-event event)]))])) (super on-event event)]))]))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(unless before? (unless before?
(when (show-first-line?) (when (show-first-line?)
(let ([admin (get-admin)]) (define admin (get-admin))
(when admin (when admin
(send admin get-view bx by bw #f #f) (send admin get-view bx by bw #f #f)
(unless (= (unbox by) 0) (unless (= (unbox by) 0)
(let ([first-line (get-text 0 (paragraph-end-position 0))] (define draw-first-line-number?
[old-pen (send dc get-pen)] (and (is-a? this line-numbers<%>)
[old-brush (send dc get-brush)] (send this showing-line-numbers?)))
[old-smoothing (send dc get-smoothing)] (define first-line (get-text 0 (paragraph-end-position 0)))
[old-α (send dc get-alpha)] (define old-pen (send dc get-pen))
[old-font (send dc get-font)] (define old-brush (send dc get-brush))
[old-text-foreground (send dc get-text-foreground)] (define old-smoothing (send dc get-smoothing))
[w-o-b? (preferences:get 'framework:white-on-black?)]) (define old-α (send dc get-alpha))
(send dc set-font (get-font)) (define old-font (send dc get-font))
(send dc set-smoothing 'aligned) (define old-text-foreground (send dc get-text-foreground))
(let-values ([(tw th _1 _2) (send dc get-text-extent first-line)]) (define w-o-b? (preferences:get 'framework:white-on-black?))
(let ([line-height (+ (unbox by) dy th 1)] (send dc set-font (get-font))
[line-left (+ (unbox bx) dx)] (send dc set-smoothing 'aligned)
[line-right (+ (unbox bx) dx (unbox bw))]) (define-values (tw th _1 _2) (send dc get-text-extent first-line))
(define line-height (+ (unbox by) dy th 1))
(if w-o-b? (define line-left (+ (unbox bx) dx))
(send dc set-pen "white" 1 'solid) (define line-right (+ (unbox bx) dx (unbox bw)))
(send dc set-pen "black" 1 'solid))
(send dc draw-line line-left line-height line-right line-height) (if w-o-b?
(send dc set-pen "white" 1 'solid)
(when (eq? (send dc get-smoothing) 'aligned) (send dc set-pen "black" 1 'solid))
(let ([start (if w-o-b? 6/10 3/10)] (send dc draw-line line-left line-height line-right line-height)
[end 0]
[steps 10]) (when (eq? (send dc get-smoothing) 'aligned)
(send dc set-pen (define start (if w-o-b? 6/10 3/10))
(if w-o-b? dark-wob-first-line-color dark-first-line-color) (define end 0)
1 (define steps 10)
'solid) (send dc set-pen
(let loop ([i steps]) (if w-o-b? dark-wob-first-line-color dark-first-line-color)
(unless (zero? i) 1
(let ([alpha-value (+ start (* (- end start) (/ i steps)))]) 'solid)
(send dc set-alpha alpha-value) (let loop ([i steps])
(send dc draw-line (unless (zero? i)
line-left (define alpha-value (+ start (* (- end start) (/ i steps))))
(+ line-height i) (send dc set-alpha alpha-value)
line-right (send dc draw-line
(+ line-height i)) line-left
(loop (- i 1)))))))) (+ line-height i)
line-right
(send dc set-alpha 1) (+ line-height i))
(send dc set-pen "gray" 1 'transparent) (loop (- i 1)))))
(send dc set-brush (if w-o-b? "black" "white") 'solid)
(send dc draw-rectangle (send dc set-alpha 1)
(+ (unbox bx) dx) (send dc set-pen "gray" 1 'transparent)
(+ (unbox by) dy) (send dc set-brush (if w-o-b? "black" "white") 'solid)
(unbox bw) (send dc draw-rectangle (+ (unbox bx) dx) (+ (unbox by) dy) (unbox bw) th)
th) (send dc set-text-foreground
(send dc set-text-foreground (send the-color-database find-color
(send the-color-database find-color (if w-o-b? "white" "black")))
(if w-o-b? "white" "black"))) (define x-start
(send dc draw-text first-line (+ (unbox bx) dx) (+ (unbox by) dy))) (cond
[draw-first-line-number?
(send dc set-text-foreground old-text-foreground) (send this do-draw-single-line dc dx dy 0 (unbox by) #f)
(send dc set-font old-font) (send dc set-pen (if w-o-b? "white" "black") 1 'solid)
(send dc set-pen old-pen) (send this draw-separator dc (unbox by) (+ (unbox by) line-height) dx dy)
(send dc set-brush old-brush) (define-values (padding-left padding-top padding-right padding-bottom) (get-padding))
(send dc set-alpha old-α) padding-left]
(send dc set-smoothing old-smoothing))))))) [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)) (super on-paint before? dc left top right bottom dx dy draw-caret))
(inherit get-style-list) (inherit get-style-list)
(define/private (get-font) (define/private (get-font)
(let* ([style-list (get-style-list)] (define style-list (get-style-list))
[std (or (send style-list find-named-style "Standard") (define std (or (send style-list find-named-style "Standard")
(send style-list basic-style))]) (send style-list basic-style)))
(send std get-font))) (send std get-font))
(super-new))) (super-new)))
@ -3841,6 +3848,8 @@ designates the character that triggers autocompletion
showing-line-numbers? showing-line-numbers?
set-line-numbers-color)) 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 ;; draws line numbers on the left hand side of a text% object
(define line-numbers-mixin (define line-numbers-mixin
(mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>)
@ -4026,37 +4035,36 @@ designates the character that triggers autocompletion
(setup-padding)) (setup-padding))
(define/private (draw-numbers dc top bottom dx dy start-line end-line) (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) (define last-paragraph #f)
(for ([line (in-range start-line end-line)]) (for ([line (in-range start-line end-line)])
(define y (line-location line)) (define y (line-location line))
(define yb (line-location line #f)) (define yb (line-location line #f))
(when (and (y . <= . bottom) (yb . >= . top)) (when (and (y . <= . bottom) (yb . >= . top))
(define view (number->string (add1 (line-paragraph line)))) (do-draw-single-line dc dx dy line y last-paragraph))
(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)))
(set! last-paragraph (line-paragraph line)))) (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 ;; 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-x (+ (left-space dc dx) x))
(define line-y1 (+ dy top)) (define line-y1 (+ dy top))
(define line-y2 (+ dy bottom)) (define line-y2 (+ dy bottom))
@ -4082,7 +4090,7 @@ designates the character that triggers autocompletion
; (printf "dx ~a\n" dx) ; (printf "dx ~a\n" dx)
;; draw it! ;; draw it!
(draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) (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)) (restore-dc-state dc saved-dc))
(define/private (text-width dc stuff) (define/private (text-width dc stuff)
@ -4097,35 +4105,32 @@ designates the character that triggers autocompletion
(define old-clipping #f) (define old-clipping #f)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(if show-line-numbers? (when show-line-numbers?
(begin (cond
(if before? [before?
(let () (define left-most (left-space dc dx))
(define left-most (left-space dc dx)) (set! old-clipping (send dc get-clipping-region))
(set! old-clipping (send dc get-clipping-region)) (define saved-dc (save-dc-state dc))
(define saved-dc (save-dc-state dc)) (setup-dc dc)
(setup-dc dc) (define clipped (make-object region% dc))
(define clipped (make-object region% dc)) (define copy (make-object region% dc))
(define all (make-object region% dc)) (if old-clipping
(define copy (make-object region% dc)) (send copy union old-clipping)
(send all set-rectangle (let ([all (make-object region% dc)])
(+ dx left) (+ dy top) (send all set-rectangle
(- right left) (- bottom top)) (+ dx left) (+ dy top)
(if old-clipping (- right left) (- bottom top))
(send copy union old-clipping) (send copy union all)))
(send copy union all)) (send clipped set-rectangle
(send clipped set-rectangle 0 (+ dy top)
0 (+ dy top) (text-width dc (number-space+1))
(text-width dc (number-space+1)) (- bottom top))
(- bottom top)) (restore-dc-state dc saved-dc)
(restore-dc-state dc saved-dc) (send copy subtract clipped)
(send copy subtract clipped) (send dc set-clipping-region copy)]
(send dc set-clipping-region copy)) [else
(begin (send dc set-clipping-region old-clipping)
(send dc set-clipping-region old-clipping) (draw-line-numbers dc left top right bottom dx dy)]))
(draw-line-numbers dc left top right bottom dx dy))))
(void))
(void)
(super on-paint before? dc left top right bottom dx dy draw-caret)) (super on-paint before? dc left top right bottom dx dy draw-caret))
(super-new) (super-new)