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,5 +1,5 @@
|
|||
|
||||
#lang scheme/unit
|
||||
|
||||
(require mzlib/class
|
||||
mzlib/list
|
||||
scheme/file
|
||||
|
|
@ -36,25 +36,6 @@
|
|||
(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)))
|
||||
|
|
@ -96,74 +77,7 @@
|
|||
"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)))
|
||||
|
||||
|
||||
|
||||
|
|
@ -305,12 +219,11 @@
|
|||
(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))
|
||||
(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)
|
||||
|
||||
|
|
@ -456,9 +369,10 @@
|
|||
(add (string-constant how-to-use-scheme) "http://www.htus.org/")
|
||||
|
||||
(for-each (λ (tool)
|
||||
(cond ((drscheme:tools:successful-tool-url tool) =>
|
||||
(cond [(drscheme:tools:successful-tool-url tool)
|
||||
=>
|
||||
(λ (url)
|
||||
(add (drscheme:tools:successful-tool-name tool) url tool-urls-menu)))))
|
||||
(add (drscheme:tools:successful-tool-name tool) url tool-urls-menu))]))
|
||||
(drscheme:tools:get-successful-tools))
|
||||
|
||||
(let loop ([additional additional])
|
||||
|
|
|
|||
|
|
@ -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