diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index f748bfdc43..fc8d2e2828 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -8,6 +8,7 @@ racket/list racket/gui/base "drsig.rkt" + "tooltip.rkt" string-constants framework setup/getinfo @@ -92,7 +93,9 @@ (for-each (λ (i<%>) (unless (is-a? language i<%>) - (error 'drracket:language:add-language "expected language ~e to implement ~e, forgot to use `drracket:language:get-default-mixin'?" language i<%>))) + (error 'drracket:language:add-language + "expected language ~e to implement ~e, forgot to use `drracket:language:get-default-mixin'?" + language i<%>))) (drracket:language:get-language-extensions)) (ensure-no-duplicate-numbers language languages) @@ -308,7 +311,9 @@ (class hierarchical-list% (init parent) - (inherit get-selected) + (inherit get-selected + client->screen + get-editor) (define/override (on-char evt) (let ([code (send evt get-key-code)]) (case code @@ -402,6 +407,108 @@ (when (and i (is-a? i hieritem-language<%>)) (something-selected this i) (ok-handler 'execute))) + + (define tooltip-timer + (new timer% + [notify-callback (λ () (show-tooltip))])) + (define tooltip-frame #f) + (define hieritem-language-to-show-in-tooltip #f) + (define hieritem-tooltip-x #f) + (define hieritem-tooltip-y #f) + (define hieritem-tooltip-w #f) + (define hieritem-tooltip-h #f) + (define/override (on-event evt) + (super on-event evt) + (cond + [(or (send evt entering?) + (send evt moving?)) + (define-values (ex ey) (send (get-editor) dc-location-to-editor-location + (send evt get-x) + (send evt get-y))) + (set!-values (hieritem-language-to-show-in-tooltip + hieritem-tooltip-x + hieritem-tooltip-y + hieritem-tooltip-w + hieritem-tooltip-h) + (find-snip ex ey)) + (when tooltip-frame (send tooltip-frame show #f)) + (send tooltip-timer stop) + (when hieritem-language-to-show-in-tooltip (send tooltip-timer start 200 #t))] + [(send evt leaving?) + (set! hieritem-language-to-show-in-tooltip #f) + (send tooltip-timer stop)])) + (define bl (box 0)) + (define bt (box 0)) + (define br (box 0)) + (define bb (box 0)) + (define/private (find-snip x y) + (let loop ([snip (send (get-editor) find-first-snip)] + [editor (get-editor)] + [x x] + [y y]) + (cond + [(not snip) (values #f #f #f #f #f)] + [else + (send editor get-snip-location snip bl bt #f) + (send editor get-snip-location snip br bb #t) + (cond + [(and (is-a? snip hierarchical-item-snip%) + (is-a? (send snip get-item) hieritem-language<%>) + (<= (unbox bl) x (unbox br)) + (<= (unbox bt) y (unbox bb))) + (define w (- (unbox br) (unbox bl))) + (define h (- (unbox bb) (unbox bt))) + (send editor local-to-global bl bt) + (define-values (x y) (client->screen + (inexact->exact (round (unbox bl))) + (inexact->exact (round (unbox bt))))) + (values (send snip get-item) + x y + (inexact->exact (round w)) + (inexact->exact (round h)))] + [(is-a? snip editor-snip%) + (define-values (es ex ey ew eh) + (loop (send (send snip get-editor) find-first-snip) + (send snip get-editor) + (- x (unbox bl)) + (- y (unbox bt)))) + (if es + (values es ex ey ew eh) + (loop (send snip next) editor x y))] + [else + (loop (send snip next) editor x y)])]))) + (define/private (show-tooltip) + (when hieritem-language-to-show-in-tooltip + (define msg (send (send hieritem-language-to-show-in-tooltip get-language) + get-one-line-summary)) + (when msg + (unless tooltip-frame + (set! tooltip-frame (new tooltip-frame% + [frame-to-track + (let loop ([w this]) + (cond + [(is-a? w top-level-window<%>) + w] + [(is-a? w area<%>) + (loop (send w get-parent))] + [else #f]))]))) + (send tooltip-frame set-tooltip (list msg)) + (send tooltip-frame show-over + (+ hieritem-tooltip-x hieritem-tooltip-w 4) + + ;; why do I have to subtract here...? + ;; that's definitely wrong. Something else + ;; must be wrong earlier to get these bad + ;; coordinates + (- hieritem-tooltip-y hieritem-tooltip-h) + + 0 + 0)))) + + (define/public (hide-tooltip) + (when tooltip-frame + (send tooltip-frame show #f))) + (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click (inherit on-click-always allow-deselect) @@ -416,11 +523,16 @@ [stretchable-height #f] [alignment '(left top)])) + (define the-racket-language-panel (new vertical-panel% + [parent languages-choice-panel] + [alignment '(left top)] + [stretchable-height #f])) + (define use-language-in-source-rb (new radio-box% [label #f] [choices (list sc-use-language-in-source)] - [parent languages-choice-panel] + [parent the-racket-language-panel] [callback (λ (rb evt) (use-language-in-source-rb-callback))])) @@ -429,15 +541,18 @@ (send use-chosen-language-rb set-selection #f) (send use-teaching-language-rb set-selection #f)) (define in-source-discussion-panel (new horizontal-panel% - [parent languages-choice-panel] + [parent the-racket-language-panel] [stretchable-height #f])) (define in-source-discussion-spacer (new horizontal-panel% [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback)) - (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) - (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) + (define in-source-discussion-editor-canvas + (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback)) + (define most-recent-languages-hier-list-selection + (preferences:get 'drracket:language-dialog:hierlist-default)) + (define most-recent-teaching-languages-hier-list-selection + (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) (define use-teaching-language-rb (new radio-box% @@ -531,11 +646,6 @@ (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) - (define one-line-summary-message (instantiate message% () - (parent parent) - (label "") - (stretchable-width #t))) - (define no-details-panel (make-object vertical-panel% details-panel)) (define languages-table (make-hasheq)) @@ -570,7 +680,6 @@ (let ([ldp (get-language-details-panel)]) (when ldp (send details-panel active-child ldp))) - (send one-line-summary-message set-label (send language get-one-line-summary)) (send revert-to-defaults-button enable #t) (set! get/set-selected-language-settings get/set-settings) (set! selected-language language)) @@ -609,7 +718,6 @@ (define (non-language-selected) (send revert-to-defaults-button enable #f) (send details-panel active-child no-details-panel) - (send one-line-summary-message set-label "") (set! get/set-selected-language-settings #f) (set! selected-language #f) (ok-handler 'disable) @@ -1308,7 +1416,9 @@ (define/override (get-extent dc x y wb hb db ab lb sp) (super get-extent dc x y wb hb db ab lb sp) (when (box? wb) (set-box! wb width))) - (super-new))) + (super-new) + (inherit set-snipclass) + (set-snipclass spacer-sc))) (define spacer-sc (new snip-class%)) (send spacer-sc set-classname "drracket:spacer-snipclass") (send spacer-sc set-version 0) diff --git a/collects/drracket/private/language-object-contract.rkt b/collects/drracket/private/language-object-contract.rkt index b149f0d2bb..98878f154c 100644 --- a/collects/drracket/private/language-object-contract.rkt +++ b/collects/drracket/private/language-object-contract.rkt @@ -54,7 +54,7 @@ (get-language-numbers (-> (cons/c number? (listof number?)))) (get-language-position (-> (cons/c string? (listof string?)))) (get-language-url (-> (or/c false/c string?))) - (get-one-line-summary (-> string?)) + (get-one-line-summary (-> (or/c #f string?))) (get-comment-character (-> (values string? char?))) (get-style-delta (-> (or/c false/c diff --git a/collects/drracket/private/language.rkt b/collects/drracket/private/language.rkt index a3e5f580a9..11ae74dfdf 100644 --- a/collects/drracket/private/language.rkt +++ b/collects/drracket/private/language.rkt @@ -119,7 +119,7 @@ (init-field module language-position (language-numbers (map (λ (x) 0) language-position)) - (one-line-summary "") + (one-line-summary #f) (language-url #f) (documentation-reference #f) (reader (λ (src port) diff --git a/collects/drracket/private/tooltip.rkt b/collects/drracket/private/tooltip.rkt index 849dead4f3..bc30fd550d 100644 --- a/collects/drracket/private/tooltip.rkt +++ b/collects/drracket/private/tooltip.rkt @@ -6,7 +6,18 @@ (define tooltip-frame% (class frame% - (inherit show reflow-container move get-width get-height is-shown?) + (inherit reflow-container move get-width get-height is-shown?) + + (init-field [frame-to-track #f]) + (define timer + (and frame-to-track + (new timer% + [notify-callback + (λ () + (unless (send frame-to-track is-shown?) + (show #f) + (send timer stop)))]))) + (define/override (on-subwindow-event r evt) (and (is-shown?) @@ -15,7 +26,15 @@ (define/public (set-tooltip ls) (send yellow-message set-lab ls)) + (define/override (show on?) + (when timer + (cond + [on? (send timer start 200 #f)] + [else (send timer stop)])) + (super show on?)) + (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f]) + (send timer start 200 #f) (reflow-container) (define mw (get-width)) (define mh (get-height)) diff --git a/collects/drracket/tool-lib.rkt b/collects/drracket/tool-lib.rkt index 5d18677932..7671016193 100644 --- a/collects/drracket/tool-lib.rkt +++ b/collects/drracket/tool-lib.rkt @@ -1156,7 +1156,8 @@ all of the names in the tools library, for use defining keybindings (proc-doc/names drracket:language-configuration:add-language - ((and/c (is-a?/c drracket:language:language<%>) drracket:language:object/c) + ((and/c (is-a?/c drracket:language:language<%>) + drracket:language:object/c) . -> . void?) (language) @@ -1176,7 +1177,8 @@ all of the names in the tools library, for use defining keybindings (proc-doc/names drracket:language-configuration:language-settings - ((or/c (is-a?/c drracket:language:language<%>) drracket:language:object/c) + ((or/c (is-a?/c drracket:language:language<%>) + drracket:language:object/c) any/c . -> . drracket:language-configuration:language-settings?) @@ -1216,7 +1218,8 @@ all of the names in the tools library, for use defining keybindings drracket:language-configuration:language-settings-language (drracket:language-configuration:language-settings? . -> . - (or/c (is-a?/c drracket:language:language<%>) drracket:language:object/c)) + (or/c (is-a?/c drracket:language:language<%>) + drracket:language:object/c)) (ls) @{Extracts the language field of a language-settings.}) @@ -1249,7 +1252,8 @@ all of the names in the tools library, for use defining keybindings If unsure of a default, the currently set language in the user's preferences can be obtained via: @racketblock[ - (preferences:get (drracket:language-configuration:get-settings-preferences-symbol))] + (preferences:get + (drracket:language-configuration:get-settings-preferences-symbol))] The @racket[parent] argument is used as the parent to the dialog. diff --git a/collects/scribblings/tools/language.scrbl b/collects/scribblings/tools/language.scrbl index 9e45b2ca6d..93827c208c 100644 --- a/collects/scribblings/tools/language.scrbl +++ b/collects/scribblings/tools/language.scrbl @@ -42,9 +42,11 @@ implementation of this interface. } @defmethod[(get-one-line-summary) - string?]{ - The result of this method is shown in the language dialog when the - user selects this language. + (or/c #f string?)]{ + The result of this method is shown in a tooltip in + the language dialog when the + user mouses over this language. If the result is + @racket[#f], no tooltip is shown. } @defmethod[(get-reader)