(module help-desk mzscheme (require (lib "unitsig.ss") (lib "string-constant.ss" "string-constants") (lib "mred.ss" "mred") (lib "external.ss" "browser") (lib "help-desk.ss" "help") (lib "framework.ss" "framework") (lib "class.ss") (lib "list.ss") "drsig.ss") (provide help-desk@) (define help-desk@ (unit/sig drscheme:help-desk^ (import [drscheme:frame : drscheme:frame^] [drscheme:language-configuration : drscheme:language-configuration/internal^] [drscheme:teachpack : drscheme:teachpack^]) ;; : -> string (define (get-computer-language-info) (let* ([language/settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)] [language (drscheme:language-configuration:language-settings-language language/settings)] [settings (drscheme:language-configuration:language-settings-settings language/settings)]) (format "~s" (list (send language get-language-position) (send language marshall-settings settings))))) ;; get-docs : (listof (cons path[short-dir-name] string[doc full name])) (define (get-docs) (let ([dirs (find-doc-names)]) (map (λ (pr) (let-values ([(base name dir?) (split-path (car pr))]) (cons name (cdr pr)))) dirs))) (define (get-teachpack-filenames) (format "~s" (drscheme:teachpack:teachpack-cache-filenames (preferences:get 'drscheme:teachpacks)))) (set-bug-report-info! "Computer Language" get-computer-language-info) (set-bug-report-info! "Teachpack filenames" get-teachpack-filenames) (define drscheme-help-desk-mixin (mixin (help-desk-frame<%> frame:standard-menus<%>) () (define/override (file-menu:create-open-recent?) #t) (define/override (file-menu:new-callback x y) (handler:edit-file #f) #t) (define/override (file-menu:between-save-as-and-print menu) (new separator-menu-item% (parent menu))) (define current-language (preferences:get drscheme:language-configuration:settings-preferences-symbol)) (define/public (set-current-language cl) (set! current-language cl)) (define/override (order-manuals x) (send (drscheme:language-configuration:language-settings-language current-language) order-manuals x)) (define/override (get-language-name) (send (drscheme:language-configuration:language-settings-language current-language) get-language-name)) (define/override (file-menu:between-new-and-open file-menu) (instantiate menu:can-restore-menu-item% () (label (string-constant plt:hd:new-help-desk)) (parent file-menu) (callback (λ (x y) (new-help-desk)))) (super file-menu:between-new-and-open file-menu)) (super-new) (inherit get-menu-bar) (inherit-field choices-panel) (letrec ([language-menu (new menu% (parent (get-menu-bar)) (label (string-constant language-menu-name)))] [change-language-callback (λ () (let ([new-settings (drscheme:language-configuration:language-dialog #f current-language this #t)]) (when new-settings (set! current-language new-settings) (send lang-message set-msg (get-language-name)) (preferences:set drscheme:language-configuration:settings-preferences-symbol new-settings))))] [lang-message (new lang-message% (button-release (λ () (change-language-callback))) (parent choices-panel) (font normal-control-font))] [language-item (new menu-item% (label (string-constant choose-language-menu-item-label)) (parent language-menu) (shortcut #\l) (callback (λ (x y) (change-language-callback))))]) (frame:reorder-menus this) (send lang-message set-msg (get-language-name)) ;; move the grow box spacer pane to the end (send choices-panel change-children (λ (l) (append (filter (λ (x) (not (is-a? x grow-box-spacer-pane%))) l) (list (car (filter (λ (x) (is-a? x grow-box-spacer-pane%)) l))))))))) (define lang-message% (class canvas% (init-field button-release font) (define/override (on-event evt) (when (send evt button-up?) (button-release))) (field [msg ""]) (define/public (set-msg l) (set! msg l) (on-paint)) (inherit get-dc get-client-size) (define/override (on-paint) (let ([dc (get-dc)] [dots "..."]) (let-values ([(tw th _1 _2) (send dc get-text-extent msg)] [(dw dh _3 _4) (send dc get-text-extent dots)] [(cw ch) (get-client-size)]) (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) (send dc set-font font) (send dc draw-rectangle 0 0 cw ch) (cond [(tw . <= . cw) (send dc draw-text msg 0 (- (/ ch 2) (/ th 2)))] [(cw . <= . dw) ;; just give up if there's not enough room to draw the dots (void)] [else (send dc set-clipping-rect 0 0 (- cw dw 2) ch) (send dc draw-text msg 0 (- (/ ch 2) (/ th 2))) (send dc set-clipping-region #f) (send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))])))) (super-new))) (define (goto-help manual link) (goto-manual-link manual link)) (define (goto-tour) (goto-hd-location 'hd-tour)) (define (goto-release-notes) (goto-hd-location 'release-notes)) (define (goto-plt-license) (goto-hd-location 'plt-license)) (define help-desk (case-lambda [() (show-help-desk)] [(key) (help-desk key #f)] [(key lucky?) (help-desk key lucky? 'keyword+index)] [(key lucky? type) (help-desk key lucky? type 'contains)] [(key lucky? type mode) (help-desk key lucky? type mode #f)] [(key lucky? type mode language) (let ([frame (or (find-help-desk-frame) (new-help-desk))]) (when language (send frame set-current-language language)) (search-for-docs/in-frame frame key (case type [(keyword) "keyword"] [(keyword+index) "keyword-index"] [(keyword+index+text) "keyword-index-text"] [else (error 'drscheme:help-desk:help-desk "unknown type argument: ~s" type)]) (case mode [(exact) "exact-match"] [(contains) "containing-match"] [(regexp) "regexp-match"] [else (error 'drscheme:help-desk:help-desk "unknown mode argument: ~s" mode)]) lucky? (map car (get-docs))))])) ;; open-url : string -> void (define (open-url x) (send-url x)) (add-help-desk-mixin drscheme-help-desk-mixin))))