From 220805a6bf93284e1e0c7ed6c95249e9ff9cdf2f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Oct 2014 22:12:27 -0500 Subject: [PATCH] improve the way tooltips line things up 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". --- .../drracket/drracket/private/tooltip.rkt | 150 ++++++++++++++++-- 1 file changed, 137 insertions(+), 13 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/tooltip.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/tooltip.rkt index 1898f3d147..dfd7e25d48 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/tooltip.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/tooltip.rkt @@ -17,7 +17,7 @@ (unless (send frame-to-track is-shown?) (show #f) (send timer stop)))]))) - + (define/override (on-subwindow-event r evt) (and (is-shown?) @@ -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?) @@ -44,13 +44,13 @@ (reflow-container) (define mw (get-width)) (define mh (get-height)) - (define (upper-left must?) + (define (upper-left must?) (define the-x (- x mw)) (define the-y (- y mh)) (if must? (move the-x the-y) (try-moving-to the-x the-y mw mh))) - (define (lower-right must?) + (define (lower-right must?) (define the-x (+ x w)) (define the-y (+ y h)) (if must? @@ -81,8 +81,15 @@ (inherit get-dc refresh get-client-size min-width min-height get-parent) - (define labels '("")) - (define/public (set-lab _ls) + + + ;; (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) (update-size) @@ -90,11 +97,14 @@ (define/private (update-size) (define dc (get-dc)) (send dc set-font small-control-font) - (define-values (w h) + (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)) +|# \ No newline at end of file