From 2f9f780727095870fda967d295965f4ac14ce909 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 8 Sep 2011 14:41:53 -0500 Subject: [PATCH] add tooltips for the module level imports in check syntax this also gets rid of the module-level imports as annotations in the bar along the buttom of a drracket window, which eliminates the use of the 'drracket:check-syntax:mouse-over status line and thus: closes PR 12186 --- collects/drracket/private/module-language.rkt | 22 +--- collects/drracket/private/syncheck/gui.rkt | 110 ++++++++++++------ .../drracket/private/syncheck/online-comp.rkt | 2 +- collects/drracket/private/tooltip.rkt | 87 ++++++++++++++ 4 files changed, 169 insertions(+), 52 deletions(-) create mode 100644 collects/drracket/private/tooltip.rkt diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index e1ceed4e85..3eb7812097 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -18,6 +18,7 @@ planet/config setup/dirs racket/place + "tooltip.rkt" "drsig.rkt" "rep.rkt" "eval-helpers.rkt" @@ -909,24 +910,11 @@ (cond [tooltip-labels (unless tooltip-frame - (set! tooltip-frame - (new (class frame% - (define/override (on-subwindow-event r evt) - (cond - [(send evt button-down?) - (hide-tooltip) - #t] - [else #f])) - (super-new [style '(no-resize-border no-caption float)] - [label ""] - [stretchable-width #f] - [stretchable-height #f] )))) - (new yellow-message% [parent tooltip-frame])) - (send (car (send tooltip-frame get-children)) set-lab tooltip-labels) - (send tooltip-frame reflow-container) + (set! tooltip-frame (new tooltip-frame%))) + (send tooltip-frame set-tooltip tooltip-labels) (define-values (rx ry) (send running-canvas client->screen 0 0)) - (send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height))) - (send tooltip-frame show #t)] + (define-values (cw ch) (send running-canvas get-client-size)) + (send tooltip-frame show-over rx ry cw ch #:prefer-upper-left? #t)] [else (when tooltip-frame (send tooltip-frame show #f))])) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 28ba64e1af..713156a3a1 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -50,7 +50,8 @@ If the namespace does not, they are colored the unbound color. "intf.rkt" "colors.rkt" "traversals.rkt" - "annotate.rkt") + "annotate.rkt" + "../tooltip.rkt") (provide tool@) (define orig-output-port (current-output-port)) @@ -198,6 +199,8 @@ If the namespace does not, they are colored the unbound color. #:transparent) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent) + (define-struct tooltip-info (text pos-left pos-right msg) #:transparent) + ;; color : string ;; text: text:basic<%> ;; start, fin: number @@ -470,10 +473,7 @@ If the namespace does not, they are colored the unbound color. (set! arrow-records (make-hasheq)) (set! bindings-table (make-hash)) (set! cleanup-texts '()) - (set! style-mapping (make-hash)) - (let ([f (get-top-level-window)]) - (when f - (send f open-status-line 'drracket:check-syntax:mouse-over)))) + (set! style-mapping (make-hash))) (define/public (syncheck:arrows-visible?) (or arrow-records cursor-location cursor-text)) @@ -493,9 +493,7 @@ If the namespace does not, they are colored the unbound color. (set! style-mapping #f) (invalidate-bitmap-cache) (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f close-status-line 'drracket:check-syntax:mouse-over))))) + (clear-tooltips))) ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void (define/public (syncheck:apply-style/remember txt start finish style mode) @@ -705,9 +703,10 @@ If the namespace does not, they are colored the unbound color. ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) - (let ([str (gui-utils:format-literal-label "~a" str)]) - (when arrow-records - (add-to-range/key text pos-left pos-right str #f #f)))) + (when arrow-records + (add-to-range/key text pos-left pos-right + (make-tooltip-info text pos-left pos-right str) + #f #f))) ;; add-to-range/key : text number number any any boolean -> void ;; adds `key' to the range `start' - `end' in the editor @@ -897,9 +896,6 @@ If the namespace does not, they are colored the unbound color. (set! cursor-location #f) (set! cursor-text #f) (set! cursor-eles #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f))) (invalidate-bitmap-cache)) (super on-event event)] [(or (send event moving?) @@ -938,20 +934,18 @@ If the namespace does not, they are colored the unbound color. (set! cursor-eles eles) (update-docs-background eles) (when eles - (update-status-line eles) + (update-tooltips eles) (for ([ele (in-list eles)]) (cond [(arrow? ele) (update-arrow-poss ele)])) (invalidate-bitmap-cache)))))] [else (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f))) (when (or cursor-location cursor-text) (set! cursor-location #f) (set! cursor-text #f) (set! cursor-eles #f) + (clear-tooltips) (invalidate-bitmap-cache))]))) (define/public (syncheck:build-popup-menu pos text) @@ -1036,22 +1030,70 @@ If the namespace does not, they are colored the unbound color. menu)])))))) - (define/private (update-status-line eles) - (let ([has-txt? #f]) - (for-each (λ (ele) - (cond - [(string? ele) - (set! has-txt? #t) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line - 'drracket:check-syntax:mouse-over - ele)))])) - eles) - (unless has-txt? - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f)))))) + (define tooltip-frame #f) + (define/private (update-tooltips eles) + (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%))) + (define tooltip-infos (filter tooltip-info? eles)) + (cond + [(null? tooltip-infos) + (send tooltip-frame show #f)] + [else + (send tooltip-frame set-tooltip (map tooltip-info-msg tooltip-infos)) + (let loop ([tooltip-infos tooltip-infos] + [l #f] + [t #f] + [r #f] + [b #f]) + (cond + [(null? tooltip-infos) + (if (and l t r b) + (send tooltip-frame show-over l t (- r l) (- b t)) + (send tooltip-frame show #f))] + [else + (define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos))) + (define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f])) + (define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f])) + (loop (cdr tooltip-infos) + (min/f tl l) + (min/f tt t) + (max/f tr r) + (max/f tb b))]))])) + + (define/private (clear-tooltips) + (when tooltip-frame (send tooltip-frame show #f))) + + (define/private (tooltip-info->ltrb tooltip) + (define xlb (box 0)) + (define ylb (box 0)) + (define xrb (box 0)) + (define yrb (box 0)) + (define left-pos (tooltip-info-pos-left tooltip)) + (define right-pos (tooltip-info-pos-right tooltip)) + (define text (tooltip-info-text tooltip)) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (define-values (xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))) + (define-values (xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))) + (define window + (let loop ([ed text]) + (cond + [(send ed get-canvas) => values] + [else + (define admin (send ed get-admin)) + (if (is-a? admin editor-snip-editor-admin<%>) + (loop (send (send admin get-snip) get-editor)) + #f)]))) + (cond + [window + (define (c n) (inexact->exact (round n))) + (define-values (glx gly) (send window client->screen (c xl-off) (c yl-off))) + (define-values (grx gry) (send window client->screen (c xr-off) (c yr-off))) + (values (min glx grx) + (min gly gry) + (max glx grx) + (max gly gry))] + [else + (values #f #f #f #f)])) (define current-colored-region #f) ;; update-docs-background : (or/c false/c (listof any)) -> void diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index a4733f5cc5..a30cfe8a68 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -31,7 +31,7 @@ (set! trace (cons (cons 'name args) trace)))) ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up - ; (log syncheck:add-mouse-over-status) ;; we don't log these as they require space in the window + (log syncheck:add-mouse-over-status) (log syncheck:add-arrow) (log syncheck:add-tail-arrow) (log syncheck:add-background-color) diff --git a/collects/drracket/private/tooltip.rkt b/collects/drracket/private/tooltip.rkt new file mode 100644 index 0000000000..57196182f1 --- /dev/null +++ b/collects/drracket/private/tooltip.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require racket/gui/base + racket/class) + +(provide tooltip-frame%) + +(define tooltip-frame% + (class frame% + (inherit show reflow-container move get-width get-height) + (define/override (on-subwindow-event r evt) + (cond + [(send evt button-down?) + (show #f) + #t] + [else #f])) + (define/public (set-tooltip ls) + (send yellow-message set-lab ls)) + + (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f]) + (reflow-container) + (define mw (get-width)) + (define mh (get-height)) + (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 the-x (+ x w)) + (define the-y (+ y h)) + (if must? + (move the-x the-y) + (try-moving-to the-x the-y mw mh))) + (if prefer-upper-left? + (or (upper-left #t) (lower-right #f) (upper-left #t)) + (or (lower-right #t) (upper-left #f) (lower-right #t))) + (show #t)) + + (define/private (try-moving-to x y w h) + (and (for/or ([m (in-range 0 (get-display-count))]) + (define-values (mx my) (get-display-left-top-inset #:monitor m)) + (define-values (mw mh) (get-display-size #:monitor m)) + (and (<= (- mx) x (+ x w) (+ (- mx) mw)) + (<= (- my) y (+ y h) (+ (- my) mh)))) + (begin (move x y) + #t))) + + (super-new [style '(no-resize-border no-caption float)] + [label ""] + [stretchable-width #f] + [stretchable-height #f]) + (define yellow-message (new yellow-message% [parent this])))) + +(define yellow-message% + (class canvas% + (inherit get-dc refresh get-client-size + min-width min-height + get-parent) + (define labels '("")) + (define/public (set-lab _ls) + (unless (equal? labels _ls) + (set! labels _ls) + (update-size) + (refresh))) + (define/private (update-size) + (define dc (get-dc)) + (send dc set-font small-control-font) + (define-values (w h _1 _2) (send dc get-text-extent (car labels))) + (send (get-parent) begin-container-sequence) + (min-width (+ 5 (inexact->exact (ceiling w)))) + (min-height (+ 5 (* (length labels) (inexact->exact (ceiling h))))) + (send (get-parent) end-container-sequence) + (send (get-parent) reflow-container)) + (define/override (on-paint) + (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))) + (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)] + [i (in-naturals)]) + (send dc draw-text label 2 (+ 2 (* i th))))) + (super-new [stretchable-width #f] [stretchable-height #f])))