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

repairs for line numbers in DrRacket

Browse Source 
original commit: be6ba896e04a7a0744810883774ee88fde9aa041
This commit is contained in:
Matthew Flatt 2011-01-07 11:57:35 -07:00
parent b886a67766
commit 4ea0968815
4 changed files with 56 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -613,11 +613,11 @@
(cond (cond
[(<= (unbox by) h) [(<= (unbox by) h)
;; the max is relevant when we're already scrolled to the top. ;; the max is relevant when we're already scrolled to the top.
(send admin scroll-to localx (max 0 (- localy h)) width height refresh? bias)] (super scroll-editor-to localx (max 0 (- localy h)) width height refresh? bias)]
[else [else
(send admin scroll-to localx localy width height refresh? bias)]))] (super scroll-editor-to localx localy width height refresh? bias)]))]
[else [else
(send admin scroll-to localx localy width height refresh? bias)]))) (super scroll-editor-to localx localy width height refresh? bias)])))
(define/override (on-event event) (define/override (on-event event)
(cond (cond
@ -3735,26 +3735,16 @@ designates the character that triggers autocompletion
;; only two values should be 'left or 'right ;; only two values should be 'left or 'right
(init-field [alignment 'right]) (init-field [alignment 'right])
(define (constructor) (define/private (number-space)
(super-new)
(setup-padding)
#;
(define space (text-width dc (number-space+1)))
#;
(set-padding space 0 0 0)
#;
(set-padding (number-space) 0 0 0))
(define (number-space)
(number->string (max (* 10 (add1 (last-line))) 100))) (number->string (max (* 10 (add1 (last-line))) 100)))
;; add an extra 0 so it looks nice ;; add an extra 0 so it looks nice
(define (number-space+1) (string-append (number-space) "0")) (define/private (number-space+1) (string-append (number-space) "0"))
(define (repaint) (define/private (repaint)
(send this invalidate-bitmap-cache)) (send this invalidate-bitmap-cache))
(define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)])) (define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)]))
(define (setup-padding) (define/private (setup-padding)
(if (showing-line-numbers?) (if (showing-line-numbers?)
(let () (let ()
(send padding-dc set-font (get-style-font)) (send padding-dc set-font (get-style-font))
@ -3776,32 +3766,30 @@ designates the character that triggers autocompletion
(define/public (set-line-numbers-color color) (define/public (set-line-numbers-color color)
(set! line-numbers-color color)) (set! line-numbers-color color))
(define (get-style-font) (define/private (get-style-font)
(let* ([style-list (send this get-style-list)] (let* ([style-list (send this get-style-list)]
[std (or (send style-list find-named-style "Standard") [std (or (send style-list find-named-style "Standard")
#t
#;
(send style-list basic-style))]) (send style-list basic-style))])
(send std get-font))) (send std get-font)))
(define-struct saved-dc-state (pen font foreground-color)) (define-struct saved-dc-state (pen font foreground-color))
(define (save-dc-state dc) (define/private (save-dc-state dc)
(saved-dc-state (send dc get-pen) (saved-dc-state (send dc get-pen)
(send dc get-font) (send dc get-font)
(send dc get-text-foreground))) (send dc get-text-foreground)))
(define (restore-dc-state dc dc-state) (define/private (restore-dc-state dc dc-state)
(send dc set-pen (saved-dc-state-pen dc-state)) (send dc set-pen (saved-dc-state-pen dc-state))
(send dc set-font (saved-dc-state-font dc-state)) (send dc set-font (saved-dc-state-font dc-state))
(send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) (send dc set-text-foreground (saved-dc-state-foreground-color dc-state)))
;; set the dc stuff to values we want ;; set the dc stuff to values we want
(define (setup-dc dc) (define/private (setup-dc dc)
(send dc set-pen "black" 1 'solid) (send dc set-pen "black" 1 'solid)
(send dc set-font (get-style-font)) (send dc set-font (get-style-font))
(send dc set-text-foreground (make-object color% line-numbers-color))) (send dc set-text-foreground (make-object color% line-numbers-color)))
(define (lighter-color color) (define/private (lighter-color color)
(define (integer number) (define (integer number)
(inexact->exact (round number))) (inexact->exact (round number)))
;; hue 0-360 ;; hue 0-360
@ -3867,37 +3855,15 @@ designates the character that triggers autocompletion
;; adjust space so that we are always at the left-most position where ;; adjust space so that we are always at the left-most position where
;; drawing looks right ;; drawing looks right
(define (left-space dc dx) (define/private (left-space dc dx)
(define left (box 0)) (define left (box 0))
(define top (box 0)) (define top (box 0))
(define width (box 0)) (define width (box 0))
(define height (box 0)) (define height (box 0))
(send (send this get-admin) get-view left top width height) (send (send this get-admin) get-view left top width height)
#|
(define width2 (box 0))
(define height2 (box 0))
(get-view-size width2 height2)
|#
#;
(printf "left ~a top ~a width ~a height ~a width2 ~a height2 ~a\n"
(unbox left) (unbox top)
(unbox width) (unbox height)
(unbox width2) (unbox height2))
(+ (unbox left) dx)) (+ (unbox left) dx))
(define/augment (after-insert start length) (define/private (draw-numbers dc top bottom dx dy start-line end-line)
(setup-padding)
(inner (void) after-insert start length))
(define/augment (after-delete start length)
(setup-padding)
(inner (void) after-delete start length))
(define/augment (after-change-style start length)
(setup-padding)
(inner (void) after-change-style start length))
(define (draw-numbers dc top bottom dx dy start-line end-line)
(define (draw-text . args) (define (draw-text . args)
(send/apply dc draw-text args)) (send/apply dc draw-text args))
@ -3927,7 +3893,7 @@ designates the character that triggers autocompletion
(set! last-paragraph (line-paragraph line)))) (set! last-paragraph (line-paragraph line))))
;; draw the line between the line numbers and the actual text ;; draw the line between the line numbers and the actual text
(define (draw-separator dc top bottom dx dy x) (define/private (draw-separator dc top bottom dx dy x)
(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))
@ -3937,7 +3903,7 @@ designates the character that triggers autocompletion
;; `line-numbers-space' will get mutated in the `on-paint' method ;; `line-numbers-space' will get mutated in the `on-paint' method
;; (define line-numbers-space 0) ;; (define line-numbers-space 0)
(define (draw-line-numbers dc left top right bottom dx dy) (define/private (draw-line-numbers dc left top right bottom dx dy)
(define saved-dc (save-dc-state dc)) (define saved-dc (save-dc-state dc))
(setup-dc dc) (setup-dc dc)
(define start-line (box 0)) (define start-line (box 0))
@ -3956,24 +3922,20 @@ designates the character that triggers autocompletion
(draw-separator dc top bottom dx dy (text-width dc (number-space))) (draw-separator dc top bottom dx dy (text-width dc (number-space)))
(restore-dc-state dc saved-dc)) (restore-dc-state dc saved-dc))
(define (text-width dc stuff) (define/private (text-width dc stuff)
(define-values (font-width font-height baseline space) (define-values (font-width font-height baseline space)
(send dc get-text-extent stuff)) (send dc get-text-extent stuff))
font-width) font-width)
(define (text-height dc stuff) (define/private (text-height dc stuff)
(define-values (font-width height baseline space) (define-values (font-width height baseline space)
(send dc get-text-extent stuff)) (send dc get-text-extent stuff))
height) height)
(define old-origin-x 0)
(define old-origin-y 0)
(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? (if show-line-numbers?
(begin (begin
#;
(set-padding (text-width dc (number-space+1)) 0 0 0)
(if before? (if before?
(let () (let ()
(define left-most (left-space dc dx)) (define left-most (left-space dc dx))
@ -3999,57 +3961,9 @@ designates the character that triggers autocompletion
(begin (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))
#;
(set-padding 0 0 0 0))
(void) (void)
#;
(when show-line-numbers?
(if before?
(let ()
;; FIXME: Moving the origin and setting the clipping rectangle
;; will probably go away when 'margin's are added to editors
;;
;; save old origin and push it to the right a little bit
;; TODO: maybe allow the line numbers to be drawn on the right hand side
;; of the editor?
(define-values (x y) (send dc get-origin))
(set! old-origin-x x)
(set! old-origin-y y)
(set! old-clipping (send dc get-clipping-region))
(define saved-dc (save-dc-state dc))
(setup-dc dc)
(define-values (font-width font-height baseline space)
(send dc get-text-extent (number-space)))
(restore-dc-state dc saved-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))
#;
(define (print-region name region)
(define-values (a b c d) (send region get-bounding-box))
(printf "~a: ~a, ~a, ~a, ~a\n" name a b c d))
(send copy subtract clipped)
(send dc set-clipping-region copy)
(send dc set-origin (+ x (text-width dc (number-space+1))) y)
;; (set! line-numbers-space (text-width dc (number-space+1)))
)
(begin
;; rest the origin and draw the line numbers
(send dc set-origin old-origin-x old-origin-y)
(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 on-paint before? dc left top right bottom dx dy draw-caret))
(constructor) (super-new)
)) (setup-padding)))

2
collects/mred/private/wxme/mline.rkt
View File

@ -1141,7 +1141,7 @@ Debugging tools:
(if is-first? (if is-first?
(paragraph-left-margin-first para) (paragraph-left-margin-first para)
(paragraph-left-margin para))))]) (paragraph-left-margin para))))])
(set-width mline totalwidth) (set-width mline (- totalwidth padding-l))
(unless (= maxscroll (mline-numscrolls mline)) (unless (= maxscroll (mline-numscrolls mline))
(set-scroll-length mline maxscroll)) (set-scroll-length mline maxscroll))
(if (= maxh (mline-h mline)) (if (= maxh (mline-h mline))

38
collects/mred/private/wxme/text.rkt
View File

@ -81,7 +81,6 @@
(inherit on-change (inherit on-change
on-local-event on-local-event
on-local-char on-local-char
scroll-editor-to
free-old-copies free-old-copies
install-copy-buffer install-copy-buffer
begin-copy-buffer begin-copy-buffer
@ -237,6 +236,7 @@
(define final-descent 0.0) ; descent of last line (define final-descent 0.0) ; descent of last line
(define initial-space 0.0) ; space from first line (define initial-space 0.0) ; space from first line
(define initial-line-base 0.0) ; inverse descent from first line (define initial-line-base 0.0) ; inverse descent from first line
(define reported-padding (vector 0.0 0.0 0.0 0.0))
(define/public (get-s-snips) snips) (define/public (get-s-snips) snips)
(define/public (get-s-last-snip) last-snip) (define/public (get-s-last-snip) last-snip)
@ -2503,13 +2503,21 @@
[nonnegative-real? t] [nonnegative-real? t]
[nonnegative-real? r] [nonnegative-real? r]
[nonnegative-real? b]) [nonnegative-real? b])
(set! padding-l (exact->inexact l)) (unless (and (= l padding-l)
(set! padding-t (exact->inexact t)) (= t padding-t)
(set! padding-r (exact->inexact r)) (= r padding-r)
(set! padding-b (exact->inexact b)) (= b padding-b))
(unless (= 0.0 max-width) (set! padding-l (exact->inexact l))
(set! max-line-width (max (- max-width padding-t padding-r) (set! padding-t (exact->inexact t))
ZERO-LINE-WIDTH)))) (set! padding-r (exact->inexact r))
(set! padding-b (exact->inexact b))
(unless (= 0.0 max-width)
(set! max-line-width (max (- max-width padding-t padding-r)
ZERO-LINE-WIDTH)))
(set! flow-invalid? #t)
(set! graphic-maybe-invalid? #t)
(set! changed? #t)
(need-refresh -1 -1)))
(def/override (get-max-width) (def/override (get-max-width)
(if (max-width . <= . 0) (if (max-width . <= . 0)
@ -3888,6 +3896,14 @@
#t] #t]
[else #f]))])) [else #f]))]))
(define/override (scroll-editor-to localx localy w h refresh? bias)
(super scroll-editor-to
(- localx padding-l)
(- localy padding-t)
(+ w padding-l padding-r)
(+ h padding-t padding-b)
refresh? bias))
(def/public (scroll-to [snip% snip] [real? localx] [real? localy] (def/public (scroll-to [snip% snip] [real? localx] [real? localy]
[nonnegative-real? w] [nonnegative-real? h] [nonnegative-real? w] [nonnegative-real? h]
[any? refresh?] [any? refresh?]
@ -4777,13 +4793,17 @@
(not (= total-width X)) (not (= total-width X))
(not (= final-descent descent)) (not (= final-descent descent))
(not (= initial-space space)) (not (= initial-space space))
(not (= line-base initial-line-base))) (not (= line-base initial-line-base))
(not (equal? reported-padding
(vector padding-l padding-t padding-r padding-b))))
(begin (begin
(set! total-height Y) (set! total-height Y)
(set! total-width X) (set! total-width X)
(set! final-descent descent) (set! final-descent descent)
(set! initial-space space) (set! initial-space space)
(set! initial-line-base line-base) (set! initial-line-base line-base)
(set! reported-padding
(vector padding-l padding-t padding-r padding-b))
#t) #t)
#f)]) #f)])

7
collects/scribblings/gui/editor-intf.scrbl
View File

@ -2037,8 +2037,11 @@ This method is normally called indirectly by @method[editor<%>
The default implementation forwards the request to the The default implementation forwards the request to the
@method[editor-admin% scroll-to] method of the current administrator, @method[editor-admin% scroll-to] method of the current administrator,
if any (see @method[editor<%> get-admin]). If the editor has no if any (see @method[editor<%> get-admin]). If a text editor has
administrator, @scheme[#f] is returned. padding (see @method[text% set-padding]), then the padding is added to
the given @techlink{location} before forwarding to the
administrator. If the editor has no administrator, @scheme[#f] is
returned.
} }