diff --git a/collects/drracket/private/drsig.rkt b/collects/drracket/private/drsig.rkt index 34ec9c70f4..5b14aea3b1 100644 --- a/collects/drracket/private/drsig.rkt +++ b/collects/drracket/private/drsig.rkt @@ -190,7 +190,8 @@ forget-saved-bug-report record-saved-bug-report (struct teachpack-callbacks (get-names remove add)) - make-teachpack-callbacks)) + make-teachpack-callbacks + add-search-help-desk-menu-item)) (define-signature drracket:frame-cm^ (<%> diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 9aa2a3d94f..97e9034407 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -764,6 +764,13 @@ If the namespace does not, they are colored the unbound color. start-selection end-selection))))) (for-each (λ (f) (f menu)) add-menus) + + (drracket:unit:add-search-help-desk-menu-item + text + menu + event + (λ () (new separator-menu-item% [parent menu]))) + (send (get-canvas) popup-menu menu (+ 1 (inexact->exact (floor (send event get-x)))) (+ 1 (inexact->exact (floor (send event get-y))))))])))) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index b8c34951e8..80a4c50233 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -129,74 +129,78 @@ module browser threading seems wrong. (set! added? #t) (new separator-menu-item% [parent menu]))))]) - (let* ([end (send text get-end-position)] - [start (send text get-start-position)]) - (unless (= 0 (send text last-position)) - (let* ([str (if (= end start) - (find-symbol - text - (call-with-values - (λ () - (send text dc-location-to-editor-location - (send event get-x) - (send event get-y))) - (λ (x y) - (send text find-position x y)))) - (send text get-text start end))] - ;; almost the same code as "search-help-desk" in "rep.rkt" - [l (send text get-canvas)] - [l (and l (send l get-top-level-window))] - [l (and l (is-a? l -frame<%>) (send l get-definitions-text))] - [l (and l (send l get-next-settings))] - [l (and l (drracket:language-configuration:language-settings-language l))] - [ctxt (and l (send l capability-value 'drscheme:help-context-term))] - [name (and l (send l get-language-name))]) - (unless (string=? str "") - (add-sep) - (let ([short-str (shorten-str str 50)]) - (make-object menu-item% - (gui-utils:format-literal-label - (string-constant search-help-desk-for) - (if (equal? short-str str) - str - (string-append short-str "..."))) - menu - (λ x (help-desk:help-desk str (list ctxt name))))))))) - - (when (is-a? text editor:basic<%>) - (let-values ([(pos text) (send text get-pos/text event)]) - (when (and pos (is-a? text text%)) - (send text split-snip pos) - (send text split-snip (+ pos 1)) - (let ([snip (send text find-snip pos 'after-or-none)]) - (when (or (is-a? snip image-snip%) - (is-a? snip image-core:image%) - (is-a? snip cache-image-snip%)) - (add-sep) - (new menu-item% - [parent menu] - [label (string-constant save-image)] - [callback - (λ (_1 _2) - (let ([fn (put-file #f - (send text get-top-level-window) - #f "untitled.png" "png")]) - (when fn - (let ([kind (filename->kind fn)]) - (cond - [kind - (cond - [(or (is-a? snip image-snip%) - (is-a? snip cache-image-snip%)) - (send (send snip get-bitmap) save-file fn kind)] - [else - (image-core:save-image-as-bitmap snip fn kind)])] - [else - (message-box - (string-constant drscheme) - "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) - - (void)))))) + (add-search-help-desk-menu-item text menu event add-sep) + + (when (is-a? text editor:basic<%>) + (let-values ([(pos text) (send text get-pos/text event)]) + (when (and pos (is-a? text text%)) + (send text split-snip pos) + (send text split-snip (+ pos 1)) + (let ([snip (send text find-snip pos 'after-or-none)]) + (when (or (is-a? snip image-snip%) + (is-a? snip image-core:image%) + (is-a? snip cache-image-snip%)) + (add-sep) + (new menu-item% + [parent menu] + [label (string-constant save-image)] + [callback + (λ (_1 _2) + (let ([fn (put-file #f + (send text get-top-level-window) + #f "untitled.png" "png")]) + (when fn + (let ([kind (filename->kind fn)]) + (cond + [kind + (cond + [(or (is-a? snip image-snip%) + (is-a? snip cache-image-snip%)) + (send (send snip get-bitmap) save-file fn kind)] + [else + (image-core:save-image-as-bitmap snip fn kind)])] + [else + (message-box + (string-constant drscheme) + "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) + + (void)))))) + + (define (add-search-help-desk-menu-item text menu event [add-sep void]) + (let* ([end (send text get-end-position)] + [start (send text get-start-position)]) + (unless (= 0 (send text last-position)) + (let* ([str (if (= end start) + (find-symbol + text + (call-with-values + (λ () + (send text dc-location-to-editor-location + (send event get-x) + (send event get-y))) + (λ (x y) + (send text find-position x y)))) + (send text get-text start end))] + ;; almost the same code as "search-help-desk" in "rep.rkt" + [l (send text get-canvas)] + [l (and l (send l get-top-level-window))] + [l (and l (is-a? l -frame<%>) (send l get-definitions-text))] + [l (and l (send l get-next-settings))] + [l (and l (drracket:language-configuration:language-settings-language l))] + [ctxt (and l (send l capability-value 'drscheme:help-context-term))] + [name (and l (send l get-language-name))]) + (unless (string=? str "") + (add-sep) + (let ([short-str (shorten-str str 50)]) + (make-object menu-item% + (gui-utils:format-literal-label + (string-constant search-help-desk-for) + (if (equal? short-str str) + str + (string-append short-str "..."))) + menu + (λ x (help-desk:help-desk str (list ctxt name)))) + (void))))))) (define (filename->kind fn) (let ([ext (filename-extension fn)]) diff --git a/collects/drracket/tool-lib.rkt b/collects/drracket/tool-lib.rkt index ec240d7cb7..4812f2d21e 100644 --- a/collects/drracket/tool-lib.rkt +++ b/collects/drracket/tool-lib.rkt @@ -625,6 +625,23 @@ all of the names in the tools library, for use defining keybindings @racket[filename], or nothing if @racket[filename] is @racket[#f] or not supplied.}) + (proc-doc/names + drracket:unit:add-search-help-desk-menu-item + (->* ((is-a?/c text%) (is-a?/c menu-item-container<%>) (is-a?/c mouse-event%)) ((-> any)) void?) + ((text menu event) + ((add-sep void))) + @{Assuming that @racket[event] represents a mouse click in @racket[text], this + adds a menu item to @racket[menu] that searches in Help Desk + for the text around the point where the click happened. + + If there is only whitespace around the insertion point, + then no @racket[menu-item%]s are added, and + @racket[add-sep] is not called. If there is something to be + added, then @racket[add-sep] is called before the menu item is + created. + }) + + ; ; ;