From 4ea0968815f524e548a4514bdeef8d05bd904a6e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Jan 2011 11:57:35 -0700 Subject: [PATCH] repairs for line numbers in DrRacket original commit: be6ba896e04a7a0744810883774ee88fde9aa041 --- collects/framework/private/text.rkt | 128 ++++----------------- collects/mred/private/wxme/mline.rkt | 2 +- collects/mred/private/wxme/text.rkt | 38 ++++-- collects/scribblings/gui/editor-intf.scrbl | 7 +- 4 files changed, 56 insertions(+), 119 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 76e976cb..89b15ccb 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -613,11 +613,11 @@ (cond [(<= (unbox by) h) ;; 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 - (send admin scroll-to localx localy width height refresh? bias)]))] + (super scroll-editor-to localx localy width height refresh? bias)]))] [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) (cond @@ -3735,26 +3735,16 @@ designates the character that triggers autocompletion ;; only two values should be 'left or 'right (init-field [alignment 'right]) - (define (constructor) - (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) + (define/private (number-space) (number->string (max (* 10 (add1 (last-line))) 100))) ;; 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)) (define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)])) - (define (setup-padding) + (define/private (setup-padding) (if (showing-line-numbers?) (let () (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) (set! line-numbers-color color)) - (define (get-style-font) + (define/private (get-style-font) (let* ([style-list (send this get-style-list)] [std (or (send style-list find-named-style "Standard") - #t - #; (send style-list basic-style))]) (send std get-font))) (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) (send dc get-font) (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-font (saved-dc-state-font dc-state)) (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) ;; 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-font (get-style-font)) (send dc set-text-foreground (make-object color% line-numbers-color))) - (define (lighter-color color) + (define/private (lighter-color color) (define (integer number) (inexact->exact (round number))) ;; 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 ;; drawing looks right - (define (left-space dc dx) + (define/private (left-space dc dx) (define left (box 0)) (define top (box 0)) (define width (box 0)) (define height (box 0)) (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)) - (define/augment (after-insert start length) - (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/private (draw-numbers dc top bottom dx dy start-line end-line) (define (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)))) ;; 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-y1 (+ dy top)) (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 ;; (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)) (setup-dc dc) (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))) (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) (send dc get-text-extent stuff)) font-width) - (define (text-height dc stuff) + (define/private (text-height dc stuff) (define-values (font-width height baseline space) (send dc get-text-extent stuff)) height) - (define old-origin-x 0) - (define old-origin-y 0) (define old-clipping #f) (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (if show-line-numbers? (begin - #; - (set-padding (text-width dc (number-space+1)) 0 0 0) (if before? (let () (define left-most (left-space dc dx)) @@ -3999,57 +3961,9 @@ designates the character that triggers autocompletion (begin (send dc set-clipping-region old-clipping) (draw-line-numbers dc left top right bottom dx dy)))) - (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)) - (constructor) - )) + (super-new) + (setup-padding))) diff --git a/collects/mred/private/wxme/mline.rkt b/collects/mred/private/wxme/mline.rkt index 57ef9292..6d81eac8 100644 --- a/collects/mred/private/wxme/mline.rkt +++ b/collects/mred/private/wxme/mline.rkt @@ -1141,7 +1141,7 @@ Debugging tools: (if is-first? (paragraph-left-margin-first para) (paragraph-left-margin para))))]) - (set-width mline totalwidth) + (set-width mline (- totalwidth padding-l)) (unless (= maxscroll (mline-numscrolls mline)) (set-scroll-length mline maxscroll)) (if (= maxh (mline-h mline)) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 248722b0..081248a6 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -81,7 +81,6 @@ (inherit on-change on-local-event on-local-char - scroll-editor-to free-old-copies install-copy-buffer begin-copy-buffer @@ -237,6 +236,7 @@ (define final-descent 0.0) ; descent of last line (define initial-space 0.0) ; space 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-last-snip) last-snip) @@ -2503,13 +2503,21 @@ [nonnegative-real? t] [nonnegative-real? r] [nonnegative-real? b]) - (set! padding-l (exact->inexact l)) - (set! padding-t (exact->inexact t)) - (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)))) + (unless (and (= l padding-l) + (= t padding-t) + (= r padding-r) + (= b padding-b)) + (set! padding-l (exact->inexact l)) + (set! padding-t (exact->inexact t)) + (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) (if (max-width . <= . 0) @@ -3888,6 +3896,14 @@ #t] [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] [nonnegative-real? w] [nonnegative-real? h] [any? refresh?] @@ -4777,13 +4793,17 @@ (not (= total-width X)) (not (= final-descent descent)) (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 (set! total-height Y) (set! total-width X) (set! final-descent descent) (set! initial-space space) (set! initial-line-base line-base) + (set! reported-padding + (vector padding-l padding-t padding-r padding-b)) #t) #f)]) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index b792f620..2734d242 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -2037,8 +2037,11 @@ This method is normally called indirectly by @method[editor<%> The default implementation forwards the request to the @method[editor-admin% scroll-to] method of the current administrator, -if any (see @method[editor<%> get-admin]). If the editor has no -administrator, @scheme[#f] is returned. +if any (see @method[editor<%> get-admin]). If a text editor has +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. }