suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merged 1134:1153 http://svn.plt-scheme.org/plt/branches/robby to trunk

Browse Source 
svn: r1154
This commit is contained in:
Robby Findler 2005-10-25 16:53:29 +00:00
parent e8e199af4b
commit e073a97123
10 changed files with 257 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/drscheme/private/app.ss
View File

@ -145,34 +145,7 @@
(λ x (λ x
(send f close)))] (send f close)))]
[messages-panel (make-object vertical-panel% left-vp)] [messages-panel (make-object vertical-panel% left-vp)]
[welcome-to-drs-msg (make-object message% (string-constant welcome-to-drscheme) messages-panel)])
[this-version (version)]
[last-version (preferences:get 'drscheme:last-version)]
[last-language (preferences:get 'drscheme:last-language)]
[welcome-to-drs-msg (make-object message% (string-constant welcome-to-drscheme) messages-panel)]
[this-version-message (make-object message%
(format (string-constant version/language)
this-version
(this-language))
messages-panel)]
[last-version-message
(let ([msg (cond
[(and last-version
last-language
(not (equal? this-version last-version))
(not (equal? (this-language) last-language)))
(format (string-constant parenthetical-last-version/language)
last-version last-language)]
[(and last-language
(not (equal? (this-language) last-language)))
(format (string-constant parenthetical-last-language)
last-language)]
[(and last-version
(not (equal? this-version last-version)))
(format (string-constant parenthetical-last-version)
last-version)]
[else #f])])
(and msg (make-object message% msg messages-panel)))])
(for-each (λ (native-lang-string language) (for-each (λ (native-lang-string language)
(unless (equal? (this-language) language) (unless (equal? (this-language) language)
(instantiate button% () (instantiate button% ()

255
collects/drscheme/private/language-configuration.ss
View File

@ -46,10 +46,6 @@
;; if a language is registered with this position, it is ;; if a language is registered with this position, it is
;; considered the default language ;; considered the default language
(define default-language-position (define default-language-position
(list (string-constant teaching-languages)
(string-constant how-to-design-programs)
(string-constant beginning-student))
#;
(list (string-constant initial-language-category) (list (string-constant initial-language-category)
(string-constant choose-a-language-language))) (string-constant choose-a-language-language)))
@ -119,9 +115,10 @@
; ;;;; ;;;; ;;;; ; ;;;; ;;;; ;;;;
;; language-dialog : (boolean language-setting -> language-setting) ;; language-dialog : (boolean language-setting -> (union #f language-setting))
;; (boolean language-setting (union #f (instanceof top-level-window%)) ;; (boolean language-setting (union #f (instanceof top-level-window%))
;; -> language-setting) ;; ->
;; (union #f language-setting))
;; allows the user to configure their language. The input language-setting is used ;; allows the user to configure their language. The input language-setting is used
;; as the defaults in the dialog and the output language setting is the user's choice ;; as the defaults in the dialog and the output language setting is the user's choice
;; todo: when button is clicked, ensure language is selected ;; todo: when button is clicked, ensure language is selected
@ -201,7 +198,7 @@
(send dialog center 'both)) (send dialog center 'both))
(send dialog show #t) (send dialog show #t)
(if cancelled? (if cancelled?
language-settings-to-show #f
(make-language-settings (make-language-settings
(get-selected-language) (get-selected-language)
(get-selected-language-settings))))) (get-selected-language-settings)))))
@ -1333,7 +1330,6 @@
(string-constant r5rs-one-line-summary) (string-constant r5rs-one-line-summary)
r5rs-mixin)) r5rs-mixin))
#;
(add-language (add-language
(make-simple 'mzscheme (make-simple 'mzscheme
(list (string-constant initial-language-category) (list (string-constant initial-language-category)
@ -1356,62 +1352,88 @@
(define (not-a-language-message) (define (not-a-language-message)
(define (main) (define (main)
(o (string-constant must-choose-language)) (o (string-constant must-choose-language))
(o "\n\n")
(o (string-constant using-a-text-book?))
(o "\n") (o "\n")
(insert-text-pls) (insert-text-pls)
(o "\n") (display-plt-schemer)
(o (string-constant seasoned-plt-schemer-before)) (display-standard-schemer)
(o (lang-link-snip (list (string-constant professional-languages) (display-future-choice))
"(module ...)")))
(o (string-constant seasoned-plt-schemer-after))
(o "\n\n")
(o (string-constant otherwise-use-before))
(o (lang-link-snip (list (string-constant professional-languages)
(string-constant plt)
(string-constant pretty-big-scheme))))
(o (string-constant otherwise-use-between))
(o (new link-snip%
[words (string-constant otherwise-use-language-dialog)]
[callback
(λ (snip)
(let ([new-lang
(language-dialog #f
(preferences:get settings-preferences-symbol)
(find-parent-from-snip snip))])
(preferences:set settings-preferences-symbol
new-lang)))]))
(o (string-constant otherwise-use-after))) (define (display-future-choice)
(let* ([txt (new text:standard-style-list%)]
(define (find-parent-from-snip snip) [es (new editor-snip%
(let loop ([snip snip]) [with-border? #f]
(let* ([admin (send snip get-admin)] [left-margin 0]
[ed (send admin get-editor)]) [top-margin 0]
(cond [bottom-margin 0]
[(send ed get-canvas) [right-margin 0]
=> [editor txt])])
(λ (c) (send txt insert (string-constant use-language-menu-item-in-future))
(send c get-top-level-window))] (send txt change-style
[else default-sd
(let ([admin (send ed get-admin)]) 0
(and (is-a? admin editor-snip-editor-admin<%>) (send txt last-position))
(loop (send admin get-snip))))])))) (o es)
(o "\n")))
(define o
(case-lambda
[(arg)
(cond
[(string? arg)
(fprintf (current-error-port) arg)]
[(is-a? arg snip%)
(write-special arg (current-error-port))])]
[args (apply fprintf (current-error-port) args)]))
(define (insert-text-pls) (define (insert-text-pls)
(for-each (for-each
display-text-pl display-text-pl
(apply append (map get-text-pls (find-relevant-directories '(textbook-pls)))))) (quicksort
(apply append (map get-text-pls (find-relevant-directories '(textbook-pls))))
(λ (x y)
(cond
[(string=? (cadr x) (string-constant how-to-design-programs))
#t]
[(string=? (string-constant how-to-design-programs) (cadr y))
#f]
[else
(string<=? (cadr x) (cadr y))])))))
(define (display-plt-schemer)
(question/answer (string-constant seasoned-plt-schemer?)
(list (string-constant professional-languages)
"(module ...)")
(list "PLT-206-small.png" "icons")
void))
(define (display-standard-schemer)
(question/answer (string-constant looking-for-standard-scheme?)
(list (string-constant professional-languages)
(string-constant plt)
(string-constant pretty-big-scheme))
(list "r5rs.png" "icons")
void))
(define (display-text-pl lst)
(let ([icon-lst (car lst)]
[text-name (cadr lst)]
[lang (cddr lst)]
[using-before (string-constant using-a-textbook-before)]
[using-after (string-constant using-a-textbook-after)])
(question/answer (string-append using-before text-name using-after)
lang
icon-lst
(λ (txt)
(send txt change-style
italic-sd
(string-length using-before)
(+ (string-length using-before)
(string-length text-name)))))))
(define (question/answer question lang icon-lst proc)
(display-two-line-choice
icon-lst
(λ (inner-txt)
(send inner-txt insert (format "~a\n~a" question (string-constant start-with-before)))
(send inner-txt change-style default-sd 0 (send inner-txt last-position))
(lang-link-snip lang inner-txt)
(let ([before-pos (send inner-txt last-position)])
(send inner-txt insert (string-constant start-with-after))
(send inner-txt change-style
default-sd
before-pos
(send inner-txt last-position)))
(proc inner-txt))))
;; get-text-pls : path -> (listof (list* string string (listof string)) ;; get-text-pls : path -> (listof (list* string string (listof string))
;; gets the questions from an info.ss file. ;; gets the questions from an info.ss file.
@ -1440,17 +1462,41 @@
qs) qs)
'()))) '())))
(define (lang-link-snip lang) (define (lang-link-snip lang txt)
#;
(let ([before (send txt last-position)])
(send txt insert (car (last-pair lang)))
(let ([after (send txt last-position)])
(send txt change-style link-sd before after)
(send txt set-clickback before after
(λ (txt start end)
(change-current-lang-to lang txt)))))
(send txt insert
(new link-snip% (new link-snip%
[words (car (last-pair lang))] [words (car (last-pair lang))]
[callback [callback
(λ (snip) (λ (snip)
(change-current-lang-to lang))])) (change-current-lang-to lang snip))])))
(define o
(case-lambda
[(arg)
(cond
[(string? arg)
(fprintf (current-error-port) arg)]
[(is-a? arg snip%)
(write-special arg (current-error-port))])]
[args (apply fprintf (current-error-port) args)]))
(define arrow-cursor (make-object cursor% 'arrow))
(define link-snip% (define link-snip%
(class editor-snip% (class editor-snip%
(init-field words callback) (init-field words callback)
(define/override (adjust-cursor dc x y editorx editory event) arrow-cursor)
(define/override (on-event dc x y editorx editory event) (define/override (on-event dc x y editorx editory event)
(when (send event button-up?) (when (send event button-up?)
(callback this))) (callback this)))
@ -1471,29 +1517,41 @@
(send txt insert words) (send txt insert words)
(send txt change-style link-sd 0 (send txt last-position)))) (send txt change-style link-sd 0 (send txt last-position))))
#;
(define link-snip%
(class string-snip%
(init-field words callback)
(define/override (adjust-cursor dc x y editorx editory event) arrow-cursor)
(define/override (on-event dc x y editorx editory event)
(when (send event button-up?)
(callback this)))
(define/override (copy)
(new link-snip% [words words] [callback callback]))
(super-make-object words)
(inherit get-flags set-flags set-style)
(set-style link-style)
(set-flags (cons 'handles-events (remq 'is-text (get-flags))))))
(define italic-sd (make-object style-delta% 'change-style 'slant))
(define link-sd (make-object style-delta% 'change-underline #t)) (define link-sd (make-object style-delta% 'change-underline #t))
(define stupid-internal-define-syntax1 (define stupid-internal-define-syntax1
(send link-sd set-delta-foreground "blue")) (begin (send link-sd set-delta-foreground "blue")
(send link-sd set-family 'default)))
(define (display-text-pl lst) (define default-sd (make-object style-delta% 'change-family 'default))
(let ([icon-lst (car lst)]
[text-name (cadr lst)]
[lang (cddr lst)])
(display-two-line-choice
icon-lst
lang
(λ (inner-txt)
(send inner-txt insert (format "~a\n~a" text-name (string-constant start-with-before)))
(send inner-txt change-style err-style-delta 0 (send inner-txt last-position))
(send inner-txt insert (lang-link-snip lang))
(let ([before-pos (send inner-txt last-position)])
(send inner-txt insert (string-constant start-with-after))
(send inner-txt change-style
err-style-delta
before-pos
(send inner-txt last-position)))))))
(define (display-two-line-choice icon-lst lang proc) (define link-style
(send (editor:get-standard-style-list)
find-or-create-style
(send (editor:get-standard-style-list) find-named-style "Standard")
link-sd))
(define (display-two-line-choice icon-lst proc)
(let* ([outer-txt (new text:standard-style-list%)] (let* ([outer-txt (new text:standard-style-list%)]
[outer-es (new editor-snip% (editor outer-txt) (with-border? #f) [outer-es (new editor-snip% (editor outer-txt) (with-border? #f)
[left-margin 0] [left-margin 0]
@ -1522,21 +1580,42 @@
(send err-sd set-delta-foreground (make-object color% 255 0 0)) (send err-sd set-delta-foreground (make-object color% 255 0 0))
err-sd)) err-sd))
(main))
;; change-current-lang-to : (listof string) -> void ;; change-current-lang-to : (listof string) -> void
(define (change-current-lang-to lang-strings) (define (change-current-lang-to lang-strings snip)
(let ([lang (ormap (let ([parent (find-parent-from-snip snip)]
[lang (ormap
(λ (x) (λ (x)
(and (equal? lang-strings (send x get-language-position)) (and (equal? lang-strings (send x get-language-position))
x)) x))
(get-languages))]) (get-languages))])
(unless lang (unless lang
(error 'change-current-lang-to "unknown language! ~s" lang-strings)) (error 'change-current-lang-to "unknown language! ~s" lang-strings))
(preferences:set settings-preferences-symbol
(let ([new-lang
(language-dialog #f
(make-language-settings lang (make-language-settings lang
(send lang default-settings))) (send lang default-settings))
(message-box (string-constant drscheme) parent)])
(format (when new-lang
(string-constant drschemes-language-now-set) (preferences:set settings-preferences-symbol new-lang)
(car (last-pair lang-strings))))))))) (when (is-a? parent drscheme:unit:frame<%>)
(send (send parent get-definitions-text) set-next-settings new-lang))))))
(main))
;; find-parent-from-editor : editor -> (union frame #f)
(define (find-parent-from-editor ed)
(cond
[(send ed get-canvas)
=>
(λ (c) (send c get-top-level-window))]
[else
(let ([admin (send ed get-admin)])
(and (is-a? admin editor-snip-editor-admin<%>)
(find-parent-from-snip (send admin get-snip))))]))
;; find-parent-from-snip : snip -> (union frame #f)
(define (find-parent-from-snip snip)
(let* ([admin (send snip get-admin)]
[ed (send admin get-editor)])
(find-parent-from-editor ed))))))

6
collects/drscheme/private/main.ss
View File

@ -321,12 +321,6 @@
(super-new))]) (super-new))])
(handler:set-recent-items-frame-superclass drs-handler-recent-items-super%)) (handler:set-recent-items-frame-superclass drs-handler-recent-items-super%))
;;
;; Show expanded language dialog when version changes
;;
(preferences:set-default 'drscheme:last-version #f (λ (x) (or (string? x) (not x))))
(preferences:set-default 'drscheme:last-language #f (λ (x) (or (symbol? x) (not x))))
(cond (cond
[(current-eventspace-has-menu-root?) [(current-eventspace-has-menu-root?)
(drscheme:frame:create-root-menubar) (drscheme:frame:create-root-menubar)

15
collects/drscheme/private/rep.ss
View File

@ -103,7 +103,7 @@ TODO
ensure-rep-shown ;; (interactions-text -> void) ensure-rep-shown ;; (interactions-text -> void)
;; make the rep visible in the frame ;; make the rep visible in the frame
needs-execution? ;; (-> boolean) needs-execution ;; (-> boolean)
;; ask if things have changed that would mean the repl is out ;; ask if things have changed that would mean the repl is out
;; of sync with the program being executed in it. ;; of sync with the program being executed in it.
@ -815,11 +815,10 @@ TODO
(ask-about-kill? #f)) (ask-about-kill? #f))
(define/public (get-in-evaluation?) in-evaluation?) (define/public (get-in-evaluation?) in-evaluation?)
(define/private (insert-warning) (define/private (insert-warning message)
(begin-edit-sequence) (begin-edit-sequence)
(let ([start (get-insertion-point)]) (let ([start (get-insertion-point)])
(insert-before (insert-before message)
(string-constant interactions-out-of-sync))
(let ([end (get-insertion-point)]) (let ([end (get-insertion-point)])
(change-style warning-style-delta start end))) (change-style warning-style-delta start end)))
(insert-before "\n") (insert-before "\n")
@ -871,13 +870,13 @@ TODO
(save-interaction-in-history prompt-position (- (last-position) 2)) (save-interaction-in-history prompt-position (- (last-position) 2))
(freeze-colorer) (freeze-colorer)
(let* ([needs-execution? (send context needs-execution?)]) (let ([needs-execution (send context needs-execution)])
(when (if (preferences:get 'drscheme:execute-warning-once) (when (if (preferences:get 'drscheme:execute-warning-once)
(and (not already-warned?) (and (not already-warned?)
needs-execution?) needs-execution)
needs-execution?) needs-execution)
(set! already-warned? #t) (set! already-warned? #t)
(insert-warning))) (insert-warning needs-execution)))
;; lets us know we are done with this one interaction ;; lets us know we are done with this one interaction
;; (since there may be multiple expressions at the prompt) ;; (since there may be multiple expressions at the prompt)

7
collects/drscheme/private/tool-contracts.ss
View File

@ -830,7 +830,7 @@
(boolean? drscheme:language-configuration:language-settings?) (boolean? drscheme:language-configuration:language-settings?)
((union false/c (is-a?/c top-level-window<%>)) ((union false/c (is-a?/c top-level-window<%>))
boolean?) boolean?)
drscheme:language-configuration:language-settings?) (union false/c drscheme:language-configuration:language-settings?))
((show-welcome? language-settings-to-show) ((show-welcome? language-settings-to-show)
((parent #t) ((parent #t)
(manuals? #f))) (manuals? #f)))
@ -857,7 +857,10 @@
"" ""
"The \\var{manuals?} argument is passed to" "The \\var{manuals?} argument is passed to"
"@flink drscheme:language-configuration:fill-language-dialog %" "@flink drscheme:language-configuration:fill-language-dialog %"
".") "."
""
"The result if \\scheme|#f| when the user cancells the dialog, and"
"the selected language if they hit ok.")
(drscheme:language-configuration:fill-language-dialog (drscheme:language-configuration:fill-language-dialog
(opt-> (opt->

15
collects/drscheme/private/unit.ss
View File

@ -469,12 +469,13 @@ module browser threading seems wrong.
(set! next-settings _next-settings) (set! next-settings _next-settings)
(change-mode-to-match)) (change-mode-to-match))
(define/public (needs-execution?) (define/public (needs-execution)
(or needs-execution-state (or needs-execution-state
(not (equal? execute-settings next-settings)))) (and (not (equal? execute-settings next-settings))
(string-constant needs-execute-language-changed))))
(define/pubment (teachpack-changed) (define/pubment (teachpack-changed)
(set! needs-execution-state #t)) (set! needs-execution-state (string-constant needs-execute-teachpack-changed)))
(define/pubment (just-executed) (define/pubment (just-executed)
(set! execute-settings next-settings) (set! execute-settings next-settings)
(set! needs-execution-state #f) (set! needs-execution-state #f)
@ -484,10 +485,10 @@ module browser threading seems wrong.
(define/pubment (already-warned) (define/pubment (already-warned)
(set! already-warned-state #t)) (set! already-warned-state #t))
(define/augment (after-insert x y) (define/augment (after-insert x y)
(set! needs-execution-state #t) (set! needs-execution-state (string-constant needs-execute-defns-edited))
(inner (void) after-insert x y)) (inner (void) after-insert x y))
(define/augment (after-delete x y) (define/augment (after-delete x y)
(set! needs-execution-state #t) (set! needs-execution-state (string-constant needs-execute-defns-edited))
(inner (void) after-delete x y)) (inner (void) after-delete x y))
(inherit get-filename) (inherit get-filename)
@ -901,8 +902,8 @@ module browser threading seems wrong.
(let-values ([(base _1 _2) (split-path (mzlib:file:normalize-path filename))]) (let-values ([(base _1 _2) (split-path (mzlib:file:normalize-path filename))])
base) base)
#f))) #f)))
(define/public (needs-execution?) (define/public (needs-execution)
(send defs needs-execution?)) (send defs needs-execution))
(define/pubment (can-close?) (define/pubment (can-close?)
(and (send defs can-close?) (and (send defs can-close?)

BIN
collects/icons/r5rs.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.9 KiB

36
collects/string-constants/english-string-constants.ss
View File

@ -225,8 +225,14 @@ please adhere to these guidelines:
(no-full-name-since-not-saved (no-full-name-since-not-saved
"The file does not have a full name because it has not yet been saved.") "The file does not have a full name because it has not yet been saved.")
(cannot-open-because-dne "Cannot open ~a because it does not exist.") (cannot-open-because-dne "Cannot open ~a because it does not exist.")
(interactions-out-of-sync
"WARNING: Interactions window is out of sync with the definitions window. Click Run.") (needs-execute-language-changed
"WARNING: The language has changed. Click Run.")
(needs-execute-teachpack-changed
"WARNING: The teachpacks have changed. Click Run.")
(needs-execute-defns-edited
"WARNING: The definitions window has changed. Click Run.")
(file-is-not-saved "The file \"~a\" is not saved.") (file-is-not-saved "The file \"~a\" is not saved.")
(save "Save") (save "Save")
(please-choose-either "Please choose either \"~a\" or \"~a\"") (please-choose-either "Please choose either \"~a\" or \"~a\"")
@ -989,23 +995,23 @@ please adhere to these guidelines:
;;; from the `not a language language' used initially in drscheme. ;;; from the `not a language language' used initially in drscheme.
(must-choose-language "DrScheme cannot process programs until you choose a programming language.") (must-choose-language "DrScheme cannot process programs until you choose a programming language.")
; intro to using a textbook ; next two appear before and after the name of a text book (which will be in italics)
(using-a-text-book? "Are you using one of the these textbooks?") (using-a-textbook-before "Using ")
; next two are used with each textbook (using-a-textbook-after "?")
; next two are before and after a language
(start-with-before "Start with ") (start-with-before "Start with ")
(start-with-after ".") (start-with-after ".")
; next ones are the default choices at the end of the list in the not-a-language-language error message (seasoned-plt-schemer? "Seasoned PLT Schemer?")
(seasoned-plt-schemer-before "Are you a seasoned PLT Schemer? Try ") (looking-for-standard-scheme? "Looking for standard Scheme?")
(seasoned-plt-schemer-after ".") (use-language-menu-item-in-future "Use the Language|Choose Language... menu item to change languages later.")
(otherwise-use-before "Otherwise, use ")
(otherwise-use-between ",\nor choose for yourself from the ")
(otherwise-use-language-dialog "language dialog") ; this one will become clickable and will open the language dialog
(otherwise-use-after ".")
; after clicking a language, this tells you that its done. The ~a is filled in with ; some of these belong ...
; the name of the language ;(otherwise-use-before "Otherwise, use ")
(drschemes-language-now-set "DrScheme's Language is now set to:\n ~a") ;(otherwise-use-between ",\nor choose for yourself from the ")
;(otherwise-use-language-dialog "language dialog") ; this one will become clickable and will open the language dialog
;(otherwise-use-after ".")
;;; debug language ;;; debug language
(unknown-debug-frame "[unknown]") (unknown-debug-frame "[unknown]")

9
collects/string-constants/italian-string-constants.ss
View File

@ -1,9 +0,0 @@
(module italian-string-constants "string-constant-lang.ss"
(is-this-your-native-language "Is Italian Your Native Language?")
(are-you-sure-you-want-to-switch-languages
"This will change the language of the GUI, which requires you to restart DrScheme. Are you sure?")
(interact-with-drscheme-in-language "Interact with DrScheme in Italian")
)

38
collects/string-constants/string-constant.ss
View File

@ -8,7 +8,6 @@
(prefix french: "french-string-constants.ss") (prefix french: "french-string-constants.ss")
(prefix dutch: "dutch-string-constants.ss") (prefix dutch: "dutch-string-constants.ss")
(prefix danish: "danish-string-constants.ss") (prefix danish: "danish-string-constants.ss")
(prefix italian: "italian-string-constants.ss")
(prefix portuguese: "portuguese-string-constants.ss") (prefix portuguese: "portuguese-string-constants.ss")
(prefix japanese: "japanese-string-constants.ss") (prefix japanese: "japanese-string-constants.ss")
(prefix traditional-chinese: "traditional-chinese-string-constants.ss") (prefix traditional-chinese: "traditional-chinese-string-constants.ss")
@ -24,8 +23,42 @@
(define (set-language-pref language) (define (set-language-pref language)
(put-preferences (list 'plt:human-language) (list language))) (put-preferences (list 'plt:human-language) (list language)))
;; table : (listof (list symbol regexp regexp))
;; this table indicates what the default value of the natural language
;; preference is. the first regexp is used under Windows and the second
;; is used on other platofmr.s All regexps are compared to the result
;; of (system-language+country)
(define table
'((english #rx"^en_" #rx"^English_")
(spanish #rx"^es_" #rx"^Espanol_")
(german #rx"^de_" #rx"^German_")
(french #rx"^fr_" #rx"French_")
(dutch #rx"nl_" #rx"^Netherlands_")
(danish #rx"^da_DK" #rx"^Danish_")
(portuguese #rx"^pt_" #rx"Portuguese_")
(japanese #rx"^ja_" #rx"^Japan_")
(traditional-chinese #rx"^zh_(HK|TW)" #rx"Chinese_China")
(simplified-chinese #rx"^zh_CN" #rx"Chinese_(Hong|Taiwan)")))
;; default-language : -> symbol
;; uses `table' and system-language+contry to find what language to start with
(define (default-language)
(let ([slc (system-language+country)])
(let loop ([table table])
(cond
[(null? table)
'english]
[else
(let ([ent (car table)])
(if (or (regexp-match (cadr ent) slc)
(and (cddr ent)
(regexp-match (caddr ent) slc)))
(car ent)
(loop (cdr table))))]))))
;; language : symbol ;; language : symbol
(define language (get-preference 'plt:human-language (lambda () 'english))) (define language (get-preference 'plt:human-language (lambda () (default-language))))
(define-syntax-set (string-constant string-constants this-language all-languages) (define-syntax-set (string-constant string-constants this-language all-languages)
;; type sc = (make-sc symbol (listof (list symbol string)) (union #f hash-table[symbol -o> #t])) ;; type sc = (make-sc symbol (listof (list symbol string)) (union #f hash-table[symbol -o> #t]))
@ -39,7 +72,6 @@
(make-sc 'german german:string-constants #f) (make-sc 'german german:string-constants #f)
(make-sc 'dutch dutch:string-constants #f) (make-sc 'dutch dutch:string-constants #f)
(make-sc 'danish danish:string-constants #f) (make-sc 'danish danish:string-constants #f)
(make-sc 'italian italian:string-constants #f)
(make-sc 'portuguese portuguese:string-constants #f) (make-sc 'portuguese portuguese:string-constants #f)
(make-sc 'japanese japanese:string-constants #f) (make-sc 'japanese japanese:string-constants #f)
(make-sc 'traditional-chinese traditional-chinese:string-constants #f) (make-sc 'traditional-chinese traditional-chinese:string-constants #f)