From 25ca892f55f5b77a9f61560e3808c8bf725194f2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 16 May 2008 02:53:41 +0000 Subject: [PATCH] some cleanup of the help-desk / drscheme interaction and the about-drscheme dialog svn: r9862 --- collects/drscheme/private/app.ss | 916 ++++++++---------- collects/drscheme/private/drsig.ss | 6 +- collects/drscheme/private/frame.ss | 8 +- collects/drscheme/private/help-desk.ss | 13 +- .../english-string-constants.ss | 4 +- 5 files changed, 420 insertions(+), 527 deletions(-) diff --git a/collects/drscheme/private/app.ss b/collects/drscheme/private/app.ss index 0f2167fa73..c017afe2e4 100644 --- a/collects/drscheme/private/app.ss +++ b/collects/drscheme/private/app.ss @@ -1,507 +1,421 @@ - #lang scheme/unit - (require mzlib/class - mzlib/list - scheme/file - string-constants - mred - framework - (lib "external.ss" "browser") - (lib "getinfo.ss" "setup") - "drsig.ss" - "../acks.ss") - - (import [prefix drscheme:unit: drscheme:unit^] - [prefix drscheme:frame: drscheme:frame^] - [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] - [prefix help-desk: drscheme:help-desk^] - [prefix drscheme:tools: drscheme:tools^]) - (export drscheme:app^) - - (define about-frame% - (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) - (init-field main-text) - (define/private (edit-menu:do const) - (send main-text do-edit-operation const)) - [define/override file-menu:create-revert? (λ () #f)] - [define/override file-menu:create-save? (λ () #f)] - [define/override file-menu:create-save-as? (λ () #f)] - [define/override file-menu:between-close-and-quit (λ (x) (void))] - [define/override edit-menu:between-redo-and-cut (λ (x) (void))] - [define/override edit-menu:between-select-all-and-find (λ (x) (void))] - [define/override edit-menu:copy-callback (λ (menu evt) (edit-menu:do 'copy))] - [define/override edit-menu:select-all-callback (λ (menu evt) (edit-menu:do 'select-all))] - [define/override edit-menu:create-find? (λ () #f)] - (super-new - (label (string-constant about-drscheme-frame-title))))) - - - ; - ; - ; - ; ; ; - ; - ; ; ; - ; ; ; ;;; ; ; ; ;;;; ;;; ;;;; ;;;; ; ; ; ;; - ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; - ; ; ; ; ; ; ;; ;;;; ;; ;;;; ;;; ; ; - ; - ; - ; - - - - (define (same-widths items) - (let ([max-width (apply max (map (λ (x) (send x get-width)) items))]) - (for-each (λ (x) (send x min-width max-width)) items))) - - (define (same-heights items) - (let ([max-height (apply max (map (λ (x) (send x get-height)) items))]) - (for-each (λ (x) (send x min-height max-height)) items))) - - (define wrap-edit% - (class text:hide-caret/selection% - (inherit begin-edit-sequence end-edit-sequence - get-max-width find-snip position-location) - (define/augment (on-set-size-constraint) - (begin-edit-sequence) - (let ([snip (find-snip 1 'after-or-none)]) - (when (is-a? snip editor-snip%) - (send (send snip get-editor) begin-edit-sequence))) - (inner (void) on-set-size-constraint)) - (define/augment (after-set-size-constraint) - (inner (void) after-set-size-constraint) - (let ([width (get-max-width)] - [snip (find-snip 1 'after-or-none)]) - (when (is-a? snip editor-snip%) - (let ([b (box 0)]) - (position-location 1 b #f #f #t) - (let ([new-width (- width 4 (unbox b))]) - (when (> new-width 0) - (send snip resize new-width - 17) ; smallest random number - (send snip set-max-height 'none)))) - (send (send snip get-editor) end-edit-sequence))) - (end-edit-sequence)) - (super-new))) - - (define (get-plt-bitmap) - (make-object bitmap% - (build-path (collection-path "icons") - (if (< (get-display-depth) 8) - "pltbw.gif" - "PLT-206.png")))) - - (define (make-release-notes-button button-panel) - (make-object button% (string-constant release-notes) button-panel - (λ (a b) - (help-desk:goto-release-notes)))) - - (define tour-frame% - (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) - (define/override (edit-menu:create-undo?) #f) - (define/override (edit-menu:create-redo?) #f) - (define/override (edit-menu:create-cut?) #f) - (define/override (edit-menu:create-copy?) #f) - (define/override (edit-menu:create-paste?) #f) - (define/override (edit-menu:create-clear?) #f) - (define/override (edit-menu:create-select-all?) #f) - (define/override (edit-menu:between-select-all-and-find x) (void)) - (define/override (edit-menu:between-find-and-preferences x) (void)) - (define/override (edit-menu:between-redo-and-cut x) (void)) - (define/override (file-menu:between-print-and-close x) (void)) - (super-new))) - - (define (invite-tour) - (let* ([f (make-object tour-frame% (format (string-constant welcome-to-something) - (string-constant drscheme)))] - [panel (send f get-area-container)] - [top-hp (make-object horizontal-panel% panel)] - [bottom-vp (make-object vertical-panel% panel)] - [left-vp (make-object vertical-panel% top-hp)] - [plt-bitmap (get-plt-bitmap)] - [plt-icon (make-object message% (if (send plt-bitmap ok?) - plt-bitmap - "[plt]") - left-vp)] - [outer-button-panel (make-object vertical-panel% top-hp)] - [top-button-panel (make-object vertical-panel% outer-button-panel)] - [bottom-button-panel (make-object vertical-panel% outer-button-panel)] - [tour-button (make-object button% (string-constant take-a-tour) - top-button-panel - (λ (x y) - (help-desk:goto-tour)) - '(border))] - [release-notes-button (make-release-notes-button top-button-panel)] - [close-button (make-object button% (string-constant close) bottom-button-panel - (λ x - (send f close)))] - [messages-panel (make-object vertical-panel% left-vp)] - [welcome-to-drs-msg (make-object message% (string-constant welcome-to-drscheme) messages-panel)]) - (for-each (λ (native-lang-string language) - (unless (equal? (this-language) language) - (instantiate button% () - (label native-lang-string) - (parent bottom-vp) - (stretchable-width #t) - (callback (λ (x1 x2) (switch-language-to f language)))))) - (string-constants is-this-your-native-language) - (all-languages)) - (send bottom-vp stretchable-height #f) - (send messages-panel stretchable-height #f) - (send bottom-button-panel stretchable-height #f) - (send top-button-panel set-alignment 'center 'center) - (send bottom-button-panel set-alignment 'center 'center) - (send messages-panel set-alignment 'center 'center) - - (send f reflow-container) - (same-heights (list bottom-button-panel messages-panel)) - (same-widths (list tour-button release-notes-button close-button)) - - (send tour-button focus) - (send f show #t))) - - - - - ; - ; - ; - ; ; ; - ; ; ; - ; ; ; ; - ; ;;; ; ;;; ;;;; ; ; ;;;; ;;; ; ; ;; ;;;; - ; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; - ; ;;;;; ; ;;; ;;;; ;;; ; ;; ;;; ; ; ;;;; - ; - ; - ; - - - (define (about-drscheme) - (let* ([e (make-object wrap-edit%)] - [main-text (make-object wrap-edit%)] - [plt-bitmap (get-plt-bitmap)] - [plt-icon (if (send plt-bitmap ok?) - (make-object image-snip% plt-bitmap) - (let ([i (make-object string-snip%)] - [label "[lambda]"]) - (send i insert label (string-length label) 0) - i))] - [editor-snip (make-object editor-snip% e #f)] - [f (make-object about-frame% main-text)] - [main-panel (send f get-area-container)] - [editor-canvas (make-object editor-canvas% main-panel)] - [button-panel (make-object horizontal-panel% main-panel)] - [top (make-object style-delta% 'change-alignment 'top)] - [d-usual (make-object style-delta% 'change-family 'decorative)] - [d-dr (make-object style-delta%)] - [d-http (make-object style-delta%)] - - [insert/clickback - (λ (str clickback) - (send e change-style d-http) - (let* ([before (send e get-start-position)] - [_ (send e insert str)] - [after (send e get-start-position)]) - (send e set-clickback before after - (λ (a b c) (clickback)) - d-http)) - (send e change-style d-usual))] - - [insert-url/external-browser - (λ (str url) - (insert/clickback str (λ () (send-url url))))]) - - (send* d-http - (copy d-usual) - (set-delta-foreground "BLUE") - (set-delta 'change-underline #t)) - (send* d-usual - (set-delta-foreground "BLACK") - (set-delta 'change-underline #f)) - - (send* d-dr (copy d-usual) (set-delta 'change-bold)) - (send d-usual set-weight-on 'normal) - (send* editor-canvas - (set-editor main-text) - (stretchable-width #t) - (stretchable-height #t)) - - (if (send plt-bitmap ok?) - (send* editor-canvas - (min-width (floor (+ (* 5/2 (send plt-bitmap get-width)) 50))) - (min-height (+ (send plt-bitmap get-height) 50))) - (send* editor-canvas - (min-width 500) - (min-height 400))) - - (send* e - (change-style d-dr) - (insert (format (string-constant welcome-to-drscheme-version/language) - (version:version) - (this-language))) - (change-style d-usual)) - - (send e insert " by ") - - (insert-url/external-browser "PLT" "http://www.plt-scheme.org/") - - (send* e - (insert ".\n") - (insert (get-authors)) - (insert "\nFor licensing information see ")) - - (insert/clickback "our software license" - (λ () (help-desk:goto-plt-license))) - - (send* e - (insert ".\n\nBased on:\n ") - (insert (banner))) - - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (send* e - (insert " The A List (c) 1997-2001 Kyle Hammond\n"))) - - (let ([tools (sort (drscheme:tools:get-successful-tools) - (lambda (a b) - (stringstring (drscheme:tools:successful-tool-spec a)) - (path->string (drscheme:tools:successful-tool-spec b)))))]) - (unless (null? tools) - (let loop ([actions1 '()] [actions2 '()] [tools tools]) - (if (pair? tools) - (let* ([successful-tool (car tools)] - [name (drscheme:tools:successful-tool-name successful-tool)] - [spec (drscheme:tools:successful-tool-spec successful-tool)] - [bm (drscheme:tools:successful-tool-bitmap successful-tool)] - [url (drscheme:tools:successful-tool-url successful-tool)]) - (define (action) - (send e insert " ") - (when bm - (send* e - (insert (make-object image-snip% bm)) - (insert #\space))) - (let ([name (or name (format "~a" spec))]) - (cond [url (insert-url/external-browser name url)] - [else (send e insert name)])) - (send e insert #\newline)) - (if name - (loop (cons action actions1) actions2 (cdr tools)) - (loop actions1 (cons action actions2) (cdr tools)))) - (begin (send e insert "\nInstalled tools:\n") - (for-each (λ (act) (act)) (reverse actions1)) - ;; (send e insert "Installed anonymous tools:\n") - (for-each (λ (act) (act)) (reverse actions2))))))) - - (send e insert "\n") - (send e insert (get-translating-acks)) - - (let* ([tour-button (make-object button% (string-constant take-a-tour) button-panel - (λ (x y) - (help-desk:goto-tour)))] - [release-notes-button (make-release-notes-button button-panel)]) - (same-widths (list tour-button release-notes-button)) - (send tour-button focus)) - (send button-panel stretchable-height #f) - (send button-panel set-alignment 'center 'center) - - (send* e - (auto-wrap #t) - (set-autowrap-bitmap #f)) - (send* main-text - (set-autowrap-bitmap #f) - (auto-wrap #t) - (insert plt-icon) - (insert editor-snip) - (change-style top 0 2) - (hide-caret #t)) - - (send f reflow-container) - - (send* main-text - (set-position 1) - (scroll-to-position 0) - (lock #t)) - - (send* e - (set-position 0) - (scroll-to-position 0) - (lock #t)) - - (when (eq? (system-type) 'macosx) - ;; otherwise, the focus is the tour button, as above - (send editor-canvas focus)) - - (send f show #t) - f)) - - - - ; - ; - ; - ; ; ; ; - ; ; - ; ; ; ; - ; ; ; ;;;; ; ; ; ;;;; ; ; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; - ; ; ;; ; ; ; ; ; ;; - ; ;;; ; ;; ; ; ; ;; ; - ; ; - ; ; - ; ; - - - ;; switch-language-to : (is-a?/c top-level-window<%>) symbol -> void - ;; doesn't return if the language changes - (define (switch-language-to parent other-language) - (define-values (other-are-you-sure other-cancel other-accept-and-quit) - (let loop ([languages (all-languages)] - [are-you-sures (string-constants are-you-sure-you-want-to-switch-languages)] - [cancels (string-constants cancel)] - [accept-and-quits (if (eq? (system-type) 'windows) - (string-constants accept-and-exit) - (string-constants accept-and-quit))]) - (cond - [(null? languages) (error 'app.ss ".1")] - [(equal? other-language (car languages)) - (values (car are-you-sures) - (car cancels) - (car accept-and-quits))] - [else (loop (cdr languages) - (cdr are-you-sures) - (cdr cancels) - (cdr accept-and-quits))]))) - (define dialog (make-object dialog% (string-constant drscheme) parent 400)) - (define (make-section are-you-sure cancel-label quit-label) - (define text (make-object text:hide-caret/selection%)) - (define ec (instantiate editor-canvas% () - (parent dialog) - (editor text) - (style '(no-hscroll)))) - (define bp (instantiate horizontal-panel% () - (parent dialog) - (alignment '(right center)))) - (define-values (quit cancel) - (gui-utils:ok/cancel-buttons - bp - (λ (x y) - (set! cancelled? #f) - (send dialog show #f)) - (λ (x y) - (send dialog show #f)) - quit-label - cancel-label)) - (send ec set-line-count 3) - (send text auto-wrap #t) - (send text set-autowrap-bitmap #f) - (send text insert are-you-sure) - (send text set-position 0 0)) - (define cancelled? #t) + +(require mzlib/class + mzlib/list + scheme/file + string-constants + mred + framework + (lib "external.ss" "browser") + (lib "getinfo.ss" "setup") + "drsig.ss" + "../acks.ss") + +(import [prefix drscheme:unit: drscheme:unit^] + [prefix drscheme:frame: drscheme:frame^] + [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] + [prefix help-desk: drscheme:help-desk^] + [prefix drscheme:tools: drscheme:tools^]) +(export drscheme:app^) + +(define about-frame% + (class (drscheme:frame:basics-mixin (frame:standard-menus-mixin frame:basic%)) + (init-field main-text) + (define/private (edit-menu:do const) + (send main-text do-edit-operation const)) + [define/override file-menu:create-revert? (λ () #f)] + [define/override file-menu:create-save? (λ () #f)] + [define/override file-menu:create-save-as? (λ () #f)] + [define/override file-menu:between-close-and-quit (λ (x) (void))] + [define/override edit-menu:between-redo-and-cut (λ (x) (void))] + [define/override edit-menu:between-select-all-and-find (λ (x) (void))] + [define/override edit-menu:copy-callback (λ (menu evt) (edit-menu:do 'copy))] + [define/override edit-menu:select-all-callback (λ (menu evt) (edit-menu:do 'select-all))] + [define/override edit-menu:create-find? (λ () #f)] + (super-new + (label (string-constant about-drscheme-frame-title))))) + + +(define (same-widths items) + (let ([max-width (apply max (map (λ (x) (send x get-width)) items))]) + (for-each (λ (x) (send x min-width max-width)) items))) + +(define (same-heights items) + (let ([max-height (apply max (map (λ (x) (send x get-height)) items))]) + (for-each (λ (x) (send x min-height max-height)) items))) + +(define wrap-edit% + (class text:hide-caret/selection% + (inherit begin-edit-sequence end-edit-sequence + get-max-width find-snip position-location) + (define/augment (on-set-size-constraint) + (begin-edit-sequence) + (let ([snip (find-snip 1 'after-or-none)]) + (when (is-a? snip editor-snip%) + (send (send snip get-editor) begin-edit-sequence))) + (inner (void) on-set-size-constraint)) + (define/augment (after-set-size-constraint) + (inner (void) after-set-size-constraint) + (let ([width (get-max-width)] + [snip (find-snip 1 'after-or-none)]) + (when (is-a? snip editor-snip%) + (let ([b (box 0)]) + (position-location 1 b #f #f #t) + (let ([new-width (- width 4 (unbox b))]) + (when (> new-width 0) + (send snip resize new-width + 17) ; smallest random number + (send snip set-max-height 'none)))) + (send (send snip get-editor) end-edit-sequence))) + (end-edit-sequence)) + (super-new))) + +(define (get-plt-bitmap) + (make-object bitmap% + (build-path (collection-path "icons") + (if (< (get-display-depth) 8) + "pltbw.gif" + "PLT-206.png")))) + + + + + + +; +; +; +; ; ; +; ; ; +; ; ; ; +; ;;; ; ;;; ;;;; ; ; ;;;; ;;; ; ; ;; ;;;; +; ; ; ;; ; ; ; ; ; ; ; ;; ;; ; +; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;; ; ; ; ; ; ; ; ; ; ; ;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ;; ; ; ; ; ;; ; ; ;; ; ; +; ;;;;; ; ;;; ;;;; ;;; ; ;; ;;; ; ; ;;;; +; +; +; + + +(define (about-drscheme) + (let* ([e (make-object wrap-edit%)] + [main-text (make-object wrap-edit%)] + [plt-bitmap (get-plt-bitmap)] + [plt-icon (if (send plt-bitmap ok?) + (make-object image-snip% plt-bitmap) + (let ([i (make-object string-snip%)] + [label "[lambda]"]) + (send i insert label (string-length label) 0) + i))] + [editor-snip (make-object editor-snip% e #f)] + [f (make-object about-frame% main-text)] + [main-panel (send f get-area-container)] + [editor-canvas (make-object editor-canvas% main-panel)] + [button-panel (make-object horizontal-panel% main-panel)] + [top (make-object style-delta% 'change-alignment 'top)] + [d-usual (make-object style-delta% 'change-family 'decorative)] + [d-dr (make-object style-delta%)] + [d-http (make-object style-delta%)] + + [insert/clickback + (λ (str clickback) + (send e change-style d-http) + (let* ([before (send e get-start-position)] + [_ (send e insert str)] + [after (send e get-start-position)]) + (send e set-clickback before after + (λ (a b c) (clickback)) + d-http)) + (send e change-style d-usual))] + + [insert-url/external-browser + (λ (str url) + (insert/clickback str (λ () (send-url url))))]) - (make-section other-are-you-sure - other-cancel - other-accept-and-quit) + (send* d-http + (copy d-usual) + (set-delta-foreground "BLUE") + (set-delta 'change-underline #t)) + (send* d-usual + (set-delta-foreground "BLACK") + (set-delta 'change-underline #f)) - (make-section (string-constant are-you-sure-you-want-to-switch-languages) - (string-constant cancel) - (if (eq? (system-type) 'windows) - (string-constant accept-and-exit) - (string-constant accept-and-quit))) + (send* d-dr (copy d-usual) (set-delta 'change-bold)) + (send d-usual set-weight-on 'normal) + (send* editor-canvas + (set-editor main-text) + (stretchable-width #t) + (stretchable-height #t)) - (send dialog show #t) + (if (send plt-bitmap ok?) + (send* editor-canvas + (min-width (floor (+ (* 5/2 (send plt-bitmap get-width)) 50))) + (min-height (+ (send plt-bitmap get-height) 50))) + (send* editor-canvas + (min-width 500) + (min-height 400))) - (unless cancelled? - (let ([set-language? #t]) - (exit:insert-on-callback - (λ () - (when set-language? - (set-language-pref other-language)))) - (exit:exit) - (set! set-language? #f)))) - - (define (add-important-urls-to-help-menu help-menu additional) - (let* ([important-urls - (instantiate menu% () - (parent help-menu) - (label (string-constant web-materials)))] - [tool-urls-menu - (instantiate menu% () - (parent help-menu) - (label (string-constant tool-web-sites)))] - [add - (λ (name url . parent) - (instantiate menu-item% () - (label name) - (parent (if (null? parent) important-urls (car parent))) - (callback - (λ (x y) - (send-url url)))))]) - (add (string-constant drscheme-homepage) "http://www.drscheme.org/") - (add (string-constant plt-homepage) "http://www.plt-scheme.org/") - (add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/") - (add (string-constant how-to-design-programs) "http://www.htdp.org/") - (add (string-constant how-to-use-scheme) "http://www.htus.org/") - - (for-each (λ (tool) - (cond ((drscheme:tools:successful-tool-url tool) => - (λ (url) - (add (drscheme:tools:successful-tool-name tool) url tool-urls-menu))))) - (drscheme:tools:get-successful-tools)) - - (let loop ([additional additional]) - (cond - [(pair? additional) - (let ([x (car additional)]) - (when (and (pair? x) - (pair? (cdr x)) - (null? (cddr x)) - (string? (car x)) - (string? (cadr x))) - (add (car x) (cadr x)))) - (loop (cdr additional))] - [else (void)])))) - - (define (add-language-items-to-help-menu help-menu) - (let ([added-any? #f]) - (for-each (λ (native-lang-string language) - (unless (equal? (this-language) language) - (unless added-any? - (make-object separator-menu-item% help-menu) - (set! added-any? #t)) - (instantiate menu-item% () - (label native-lang-string) - (parent help-menu) - (callback (λ (x1 x2) (switch-language-to #f language)))))) - good-interact-strings - languages-with-good-labels))) - - (define-values (languages-with-good-labels good-interact-strings) - (let loop ([langs (all-languages)] - [strs (string-constants interact-with-drscheme-in-language)] - [good-langs '()] - [good-strs '()]) + (send* e + (change-style d-dr) + (insert (format (string-constant welcome-to-drscheme-version/language) + (version:version) + (this-language))) + (change-style d-usual)) + + (send e insert " by ") + + (insert-url/external-browser "PLT" "http://www.plt-scheme.org/") + + (send* e + (insert ".\n") + (insert (get-authors)) + (insert "\nFor licensing information see ")) + + (insert/clickback "our software license" + (λ () (help-desk:goto-plt-license))) + + (send* e + (insert ".\n\nBased on:\n ") + (insert (banner))) + + (when (or (eq? (system-type) 'macos) + (eq? (system-type) 'macosx)) + (send* e + (insert " The A List (c) 1997-2001 Kyle Hammond\n"))) + + (let ([tools (sort (drscheme:tools:get-successful-tools) + (lambda (a b) + (stringstring (drscheme:tools:successful-tool-spec a)) + (path->string (drscheme:tools:successful-tool-spec b)))))]) + (unless (null? tools) + (let loop ([actions1 '()] [actions2 '()] [tools tools]) + (if (pair? tools) + (let* ([successful-tool (car tools)] + [name (drscheme:tools:successful-tool-name successful-tool)] + [spec (drscheme:tools:successful-tool-spec successful-tool)] + [bm (drscheme:tools:successful-tool-bitmap successful-tool)] + [url (drscheme:tools:successful-tool-url successful-tool)]) + (define (action) + (send e insert " ") + (when bm + (send* e + (insert (make-object image-snip% bm)) + (insert #\space))) + (let ([name (or name (format "~a" spec))]) + (cond [url (insert-url/external-browser name url)] + [else (send e insert name)])) + (send e insert #\newline)) + (if name + (loop (cons action actions1) actions2 (cdr tools)) + (loop actions1 (cons action actions2) (cdr tools)))) + (begin (send e insert "\nInstalled tools:\n") + (for-each (λ (act) (act)) (reverse actions1)) + ;; (send e insert "Installed anonymous tools:\n") + (for-each (λ (act) (act)) (reverse actions2))))))) + + (send e insert "\n") + (send e insert (get-translating-acks)) + + (let* ([docs-button (new button% + [label (string-constant the-documentation)] + [parent button-panel] + [callback (λ (x y) (help-desk:help-desk))])]) + (send docs-button focus)) + (send button-panel stretchable-height #f) + (send button-panel set-alignment 'center 'center) + + (send* e + (auto-wrap #t) + (set-autowrap-bitmap #f)) + (send* main-text + (set-autowrap-bitmap #f) + (auto-wrap #t) + (insert plt-icon) + (insert editor-snip) + (change-style top 0 2) + (hide-caret #t)) + + (send f reflow-container) + + (send* main-text + (set-position 1) + (scroll-to-position 0) + (lock #t)) + + (send* e + (set-position 0) + (scroll-to-position 0) + (lock #t)) + + (when (eq? (system-type) 'macosx) + ;; otherwise, the focus is the tour button, as above + (send editor-canvas focus)) + + (send f show #t) + f)) + + + +; +; +; +; ; ; ; +; ; +; ; ; ; +; ; ; ;;;; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; +; ; ;; ; ; ; ; ; ;; +; ;;; ; ;; ; ; ; ;; ; +; ; +; ; +; ; + + +;; switch-language-to : (is-a?/c top-level-window<%>) symbol -> void +;; doesn't return if the language changes +(define (switch-language-to parent other-language) + (define-values (other-are-you-sure other-cancel other-accept-and-quit) + (let loop ([languages (all-languages)] + [are-you-sures (string-constants are-you-sure-you-want-to-switch-languages)] + [cancels (string-constants cancel)] + [accept-and-quits (if (eq? (system-type) 'windows) + (string-constants accept-and-exit) + (string-constants accept-and-quit))]) (cond - [(null? strs) (values (reverse good-langs) - (reverse good-strs))] - [else (let ([str (car strs)] - [lang (car langs)]) - (if (andmap (λ (char) (send normal-control-font screen-glyph-exists? char #t)) - (string->list str)) - (loop (cdr langs) - (cdr strs) - (cons lang good-langs) - (cons str good-strs)) - (loop (cdr langs) (cdr strs) good-langs good-strs)))]))) + [(null? languages) (error 'app.ss ".1")] + [(equal? other-language (car languages)) + (values (car are-you-sures) + (car cancels) + (car accept-and-quits))] + [else (loop (cdr languages) + (cdr are-you-sures) + (cdr cancels) + (cdr accept-and-quits))]))) + (define dialog (make-object dialog% (string-constant drscheme) parent 400)) + (define (make-section are-you-sure cancel-label quit-label) + (define text (make-object text:hide-caret/selection%)) + (define ec (instantiate editor-canvas% () + (parent dialog) + (editor text) + (style '(no-hscroll)))) + (define bp (instantiate horizontal-panel% () + (parent dialog) + (alignment '(right center)))) + (define-values (quit cancel) + (gui-utils:ok/cancel-buttons + bp + (λ (x y) + (set! cancelled? #f) + (send dialog show #f)) + (λ (x y) + (send dialog show #f)) + quit-label + cancel-label)) + (send ec set-line-count 3) + (send text auto-wrap #t) + (send text set-autowrap-bitmap #f) + (send text insert are-you-sure) + (send text set-position 0 0)) + (define cancelled? #t) + + (make-section other-are-you-sure + other-cancel + other-accept-and-quit) + + (make-section (string-constant are-you-sure-you-want-to-switch-languages) + (string-constant cancel) + (if (eq? (system-type) 'windows) + (string-constant accept-and-exit) + (string-constant accept-and-quit))) + + (send dialog show #t) + + (unless cancelled? + (let ([set-language? #t]) + (exit:insert-on-callback + (λ () + (when set-language? + (set-language-pref other-language)))) + (exit:exit) + (set! set-language? #f)))) + +(define (add-important-urls-to-help-menu help-menu additional) + (let* ([important-urls + (instantiate menu% () + (parent help-menu) + (label (string-constant web-materials)))] + [tool-urls-menu + (instantiate menu% () + (parent help-menu) + (label (string-constant tool-web-sites)))] + [add + (λ (name url . parent) + (instantiate menu-item% () + (label name) + (parent (if (null? parent) important-urls (car parent))) + (callback + (λ (x y) + (send-url url)))))]) + (add (string-constant drscheme-homepage) "http://www.drscheme.org/") + (add (string-constant plt-homepage) "http://www.plt-scheme.org/") + (add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/") + (add (string-constant how-to-design-programs) "http://www.htdp.org/") + (add (string-constant how-to-use-scheme) "http://www.htus.org/") + + (for-each (λ (tool) + (cond [(drscheme:tools:successful-tool-url tool) + => + (λ (url) + (add (drscheme:tools:successful-tool-name tool) url tool-urls-menu))])) + (drscheme:tools:get-successful-tools)) + + (let loop ([additional additional]) + (cond + [(pair? additional) + (let ([x (car additional)]) + (when (and (pair? x) + (pair? (cdr x)) + (null? (cddr x)) + (string? (car x)) + (string? (cadr x))) + (add (car x) (cadr x)))) + (loop (cdr additional))] + [else (void)])))) + +(define (add-language-items-to-help-menu help-menu) + (let ([added-any? #f]) + (for-each (λ (native-lang-string language) + (unless (equal? (this-language) language) + (unless added-any? + (make-object separator-menu-item% help-menu) + (set! added-any? #t)) + (instantiate menu-item% () + (label native-lang-string) + (parent help-menu) + (callback (λ (x1 x2) (switch-language-to #f language)))))) + good-interact-strings + languages-with-good-labels))) + +(define-values (languages-with-good-labels good-interact-strings) + (let loop ([langs (all-languages)] + [strs (string-constants interact-with-drscheme-in-language)] + [good-langs '()] + [good-strs '()]) + (cond + [(null? strs) (values (reverse good-langs) + (reverse good-strs))] + [else (let ([str (car strs)] + [lang (car langs)]) + (if (andmap (λ (char) (send normal-control-font screen-glyph-exists? char #t)) + (string->list str)) + (loop (cdr langs) + (cdr strs) + (cons lang good-langs) + (cons str good-strs)) + (loop (cdr langs) (cdr strs) good-langs good-strs)))]))) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 54ac99bd98..202b30833e 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -214,7 +214,6 @@ ()) (define-signature drscheme:app^ extends drscheme:app-cm^ (about-drscheme - invite-tour add-language-items-to-help-menu add-important-urls-to-help-menu switch-language-to)) @@ -227,11 +226,8 @@ (define-signature drscheme:help-desk-cm^ ()) (define-signature drscheme:help-desk^ extends drscheme:help-desk-cm^ - (goto-help - goto-tour - goto-release-notes + (help-desk goto-plt-license - help-desk get-docs)) (define-signature drscheme:language-cm^ diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss index 28808a266e..12b55a20ee 100644 --- a/collects/drscheme/private/frame.ss +++ b/collects/drscheme/private/frame.ss @@ -132,13 +132,7 @@ (regexp-split #rx";" (symbol->string (car binding))))) (define/override (help-menu:before-about help-menu) - (make-help-desk-menu-item help-menu) - '(make-object menu-item% - (format (string-constant welcome-to-something) - (string-constant drscheme)) - help-menu - (λ (item evt) - (drscheme:app:invite-tour)))) + (make-help-desk-menu-item help-menu)) (define/override (help-menu:about-callback item evt) (drscheme:app:about-drscheme)) (define/override (help-menu:about-string) (string-constant about-drscheme)) diff --git a/collects/drscheme/private/help-desk.ss b/collects/drscheme/private/help-desk.ss index ca4887120a..3b057f4e6f 100644 --- a/collects/drscheme/private/help-desk.ss +++ b/collects/drscheme/private/help-desk.ss @@ -64,17 +64,8 @@ (send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))])))) (super-new))) -(define (goto-manual-link a b) (error 'goto-maual-link "~s ~s" a b)) -(define (goto-hd-location b) (error 'goto-hd-location "~s" b)) - -(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 (get-docs) - ;(error 'help-desk.ss "get-docs") - '()) +(define (goto-plt-license) (void)) +(define (get-docs) '()) (define help-desk (case-lambda diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index ef3dc506c2..80779fc2cc 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -379,9 +379,7 @@ please adhere to these guidelines: ;;; about box (about-drscheme-frame-title "About DrScheme") - (take-a-tour "Take a Tour!") - (release-notes "Release Notes") - + (the-documentation "The Documentation") ;;; save file in particular format prompting. (save-as-plain-text "Save this file as plain text?")