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

add tooltips for the module level imports in check syntax

Browse Source 
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
This commit is contained in:
Robby Findler 2011-09-08 14:41:53 -05:00
parent f61b9efea4
commit 2f9f780727
4 changed files with 169 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/drracket/private/module-language.rkt
View File

@ -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))]))

110
collects/drracket/private/syncheck/gui.rkt
View File

@ -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

2
collects/drracket/private/syncheck/online-comp.rkt
View File

@ -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)

87
collects/drracket/private/tooltip.rkt Normal file
View File

@ -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])))