some cleanup of the help-desk / drscheme interaction and the about-drscheme dialog
svn: r9862
This commit is contained in:
Robby Findler
parent
2bf1a2cde9
commit
25ca892f55
|
|
@ -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)
|
||||
(string<? (path->string (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)
|
||||
(string<? (path->string (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)))])))
|
||||
|
|
|
|||
|
|
@ -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^
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user