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
This commit is contained in:
Robby Findler
parent
eea4d30f1b
commit
93404aaf3a
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user