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

improve the way tooltips line things up

Browse Source 
In particular, when a single tooltip entry has a string like:

  "wwww\n  ii"

then be sure to line up the first "i" underneath the third "w".
This commit is contained in:
Robby Findler 2014-10-06 22:12:27 -05:00
parent 8784bd984f
commit 220805a6bf
1 changed files with 137 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
pkgs/drracket-pkgs/drracket/drracket/private/tooltip.rkt
View File

@ -30,7 +30,7 @@
(apply
append
(for/list ([str (in-list ls)])
(regexp-split #rx"\n" str))))
(strings->strings+spacers (regexp-split #rx"\n" str)))))
(send yellow-message set-lab broken-up-lines))
(define/override (show on?)
@ -81,7 +81,14 @@
(inherit get-dc refresh get-client-size
min-width min-height
get-parent)
(define labels '(""))
;; (listof (list string string))
;; the first string indicates the amount of leading space
;; to give; it should be as much width as the first string
;; would require to draw. The second string is then actually drawn
(define labels '(("" "")))
(define/public (set-lab _ls)
(unless (equal? labels _ls)
(set! labels _ls)
@ -92,9 +99,12 @@
(send dc set-font small-control-font)
(define-values (w h)
(for/fold ([w 0] [h 0])
([lab (in-list labels)])
(define-values (this-w this-h _1 _2) (send dc get-text-extent lab))
(values (max this-w w)
([space+label (in-list labels)])
(define space (list-ref space+label 0))
(define label (list-ref space+label 1))
(define-values (space-w _1 _2 _3) (send dc get-text-extent space))
(define-values (this-w this-h _4 _5) (send dc get-text-extent label))
(values (max (+ space-w this-w) w)
(max this-h h))))
(send (get-parent) begin-container-sequence)
(min-width (+ 5 (inexact->exact (ceiling w))))
@ -105,12 +115,126 @@
(define dc (get-dc))
(send dc set-font small-control-font)
(define-values (w h) (get-client-size))
(define-values (tw th _1 _2) (send dc get-text-extent (car labels)))
(define-values (_1 th _2 _3) (send dc get-text-extent "yX"))
(send dc set-pen "black" 1 'transparent)
(send dc set-brush "LemonChiffon" 'solid)
(send dc set-pen "black" 1 'solid)
(send dc draw-rectangle 0 0 w h)
(for ([label (in-list labels)]
(for ([space+label (in-list labels)]
[i (in-naturals)])
(send dc draw-text label 2 (+ 2 (* i th)))))
(define space (list-ref space+label 0))
(define label (list-ref space+label 1))
(define-values (space-w _1 _2 _3) (send dc get-text-extent space))
(send dc draw-text label (+ 2 space-w) (+ 2 (* i th)))))
(super-new [stretchable-width #f] [stretchable-height #f])))
(define (strings->strings+spacers strs)
(let loop ([strs strs]
[prefix ""])
(cond
[(null? strs) '()]
[else
(define str (car strs))
(define leading-spaces (car (regexp-match #rx"^ *" str)))
(define this-entry
(cond
[(<= (string-length prefix) (string-length leading-spaces))
(list prefix (substring str (string-length prefix) (string-length str)))]
[else
(list (substring prefix 0 (string-length leading-spaces))
(substring str (string-length leading-spaces) (string-length str)))]))
(define new-prefix
(cond
[(< (string-length prefix) (string-length leading-spaces))
prefix]
[else
(string-append (substring prefix 0 (string-length leading-spaces))
(substring str (string-length leading-spaces) (string-length str)))]))
(cons this-entry (loop (cdr strs) new-prefix))])))
(module+ test
(require rackunit)
(check-equal? (strings->strings+spacers '()) '())
(check-equal? (strings->strings+spacers '("x")) '(("" "x")))
(check-equal? (strings->strings+spacers '("x" "x")) '(("" "x") ("" "x")))
(check-equal? (strings->strings+spacers '("xx" " x")) '(("" "xx") ("x" "x")))
(check-equal? (strings->strings+spacers '("abcdef"
" pqrst"
" ijkl"
" mno"))
'(("" "abcdef")
("a" "pqrst")
("ap" "ijkl")
("api" "mno")))
(check-equal? (strings->strings+spacers '("abcdef"
" pqrst"
" ijkl"
" mnozz"))
'(("" "abcdef")
("a" "pqrst")
("ap" "ijkl")
("a" "mnozz")))
(check-equal? (strings->strings+spacers '("abcdef"
" pqrst"
" mnozz"
" ijkl"))
'(("" "abcdef")
("a" "pqrst")
("a" "mnozz")
("am" "ijkl")))
(check-equal? (strings->strings+spacers '("abcdef"
" pqrst"
" ijkl"
" mnoz"))
'(("" "abcdef")
("a" "pqrst")
("ap" "ijkl")
("ap" "mnoz")))
(check-equal? (strings->strings+spacers '(" def"
"abcxyz"))
'(("" " def")
("" "abcxyz")))
(check-equal? (strings->strings+spacers '("abcdef"
" xyz"
" pqrstuv"))
'(("" "abcdef")
("abc" "xyz")
("abcxyz" " pqrstuv"))))
#|
(module+ main
(require racket/gui/base)
(define c%
(class canvas%
(inherit get-client-size client->screen)
(define state #f)
(define/override (on-event evt)
(define-values (w h) (get-client-size))
(define new-state
(cond
[(not (<= 0 (send evt get-y) h)) #f]
[(<= 0 (send evt get-x) (/ w 2))
'left]
[(<= (/ w 2) (send evt get-x) w)
'right]
[else
#f]))
(unless (equal? new-state state)
(define old-state state)
(set! state new-state)
(send tooltip-frame show #f)
(when state
(send tooltip-frame set-tooltip
(case state
[(left) '("abcdef\n ghij\n klmn\n op\n q")]
[(right) '("right")]))
(define-values (sx sy) (client->screen 10 10))
(send tooltip-frame show-over sx sy 10 10))))
(super-new)
(define tooltip-frame (new tooltip-frame%))))
(define f (new frame% [label ""] [width 200] [height 200]))
(define c (new c% [parent f]))
(send f show #t))
|#