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

the language's name gets truncated now, based on the width of the drscheme window (the minimum size is the size of the words 'programming language' just above)

Browse Source 
svn: r6671
This commit is contained in:
Robby Findler 2007-06-16 14:35:34 +00:00
parent 6c5230342d
commit 1f749fae97
1 changed files with 37 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/drscheme/private/unit.ss
View File

@ -3237,16 +3237,14 @@ module browser threading seems wrong.
[vp (new vertical-panel% [vp (new vertical-panel%
[parent info-panel] [parent info-panel]
[alignment '(left center)] [alignment '(left center)]
[stretchable-width #f] [stretchable-width #t]
[stretchable-height #f])] [stretchable-height #f])]
[spacer (new horizontal-panel% [parent info-panel])]
[l-m-label (new language-label-message% [parent vp] [frame this])] [l-m-label (new language-label-message% [parent vp] [frame this])]
[language-message (new language-message% [parent vp])]) [language-message (new language-message% [parent vp])])
(send info-panel change-children (send info-panel change-children
(λ (l) (λ (l)
(list* vp (list* vp
spacer (remq* (list vp) l))))
(remq* (list spacer vp) l))))
language-message)) language-message))
(update-save-message) (update-save-message)
@ -3408,10 +3406,11 @@ module browser threading seems wrong.
(class canvas% (class canvas%
(inherit get-dc get-client-size refresh) (inherit get-dc get-client-size refresh)
(define message "") (define message "")
(define to-draw-message #f)
(define/public (set-lang l) (define/public (set-lang l)
(unless (equal? l message) (unless (equal? l message)
(set! message l) (set! message l)
(update-min-widths) (compute-new-string)
(refresh))) (refresh)))
(define yellow? #f) (define yellow? #f)
@ -3421,16 +3420,42 @@ module browser threading seems wrong.
(equal? l message)) (equal? l message))
(set! yellow? y?) (set! yellow? y?)
(set! message l) (set! message l)
(update-min-widths) (compute-new-string)
(refresh))) (refresh)))
(define/override (on-size w h)
(compute-new-string)
(refresh))
(define/private (compute-new-string)
(let-values ([(cw ch) (get-client-size)])
(let ([width-to-use (- cw (get-left-side-padding))])
(let loop ([c (string-length message)])
(cond
[(= c 0) (set! to-draw-message "")]
[else
(let ([candidate (if (= c (string-length message))
message
(string-append (substring message 0 c) "..."))])
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)])
(cond
[(tw . <= . width-to-use) (set! to-draw-message candidate)]
[else
(loop (- c 1))])))])))))
(define/public (set-yellow y?) (define/public (set-yellow y?)
(unless (equal? y? yellow?) (unless (equal? y? yellow?)
(set! yellow? y?) (set! yellow? y?)
(refresh))) (refresh)))
(define last-time-width 0)
(define last-time-string "")
(define/override (on-paint) (define/override (on-paint)
(unless to-draw-message
(compute-new-string))
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(send dc set-font small-control-font)
(let-values ([(w h) (get-client-size)]) (let-values ([(w h) (get-client-size)])
(send dc set-pen (get-panel-background) 1 'transparent) (send dc set-pen (get-panel-background) 1 'transparent)
(send dc set-brush (get-panel-background) 'transparent) (send dc set-brush (get-panel-background) 'transparent)
@ -3439,20 +3464,17 @@ module browser threading seems wrong.
(send dc set-pen "black" 1 'transparent) (send dc set-pen "black" 1 'transparent)
(send dc set-brush "yellow" 'solid) (send dc set-brush "yellow" 'solid)
(send dc draw-rectangle (get-left-side-padding) 0 (- w (get-left-side-padding)) h)) (send dc draw-rectangle (get-left-side-padding) 0 (- w (get-left-side-padding)) h))
(send dc set-font small-control-font) (send dc draw-text to-draw-message (get-left-side-padding) 0))))
(send dc draw-text message (get-left-side-padding) 0))))
(super-new [style '(transparent)]) (super-new [style '(transparent)])
(inherit stretchable-width stretchable-height) (inherit stretchable-width stretchable-height)
(stretchable-width #f) (stretchable-width #t)
(stretchable-height #f) (stretchable-height #f)
(inherit min-width min-height) (inherit min-height)
(define (update-min-widths)
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(let-values ([(w2 h2 _3 _4) (send dc get-text-extent message small-control-font)]) (let-values ([(w2 h2 _3 _4) (send dc get-text-extent message small-control-font)])
(min-width (inexact->exact (floor (+ (get-left-side-padding) w2)))) (min-height (inexact->exact (floor h2)))))))
(min-height (inexact->exact (floor h2))))))))
(define language-label-message% (define language-label-message%
(class name-message% (class name-message%