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

Some raketization, #lang, and reformat

Browse Source
This commit is contained in:
Eli Barzilay 2010-09-13 16:22:51 -04:00
parent f67bb10c19
commit d440e17dde
1 changed files with 233 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
collects/string-constants/string-constant.rkt
View File

@ -1,37 +1,36 @@
#lang mzscheme
(module string-constant mzscheme (require-for-syntax mzlib/etc
(require-for-syntax mzlib/etc
mzlib/list mzlib/list
(prefix english: "english-string-constants.ss") (prefix english: "english-string-constants.rkt")
(prefix spanish: "spanish-string-constants.ss") (prefix spanish: "spanish-string-constants.rkt")
(prefix german: "german-string-constants.ss") (prefix german: "german-string-constants.rkt")
(prefix french: "french-string-constants.ss") (prefix french: "french-string-constants.rkt")
(prefix dutch: "dutch-string-constants.ss") (prefix dutch: "dutch-string-constants.rkt")
(prefix danish: "danish-string-constants.ss") (prefix danish: "danish-string-constants.rkt")
(prefix portuguese: "portuguese-string-constants.ss") (prefix portuguese: "portuguese-string-constants.rkt")
(prefix japanese: "japanese-string-constants.ss") (prefix japanese: "japanese-string-constants.rkt")
(prefix traditional-chinese: "traditional-chinese-string-constants.ss") (prefix traditional-chinese: "traditional-chinese-string-constants.rkt")
(prefix simplified-chinese: "simplified-chinese-string-constants.ss") (prefix simplified-chinese: "simplified-chinese-string-constants.rkt")
(prefix russian: "russian-string-constants.ss") (prefix russian: "russian-string-constants.rkt")
(prefix ukrainian: "ukrainian-string-constants.ss") (prefix ukrainian: "ukrainian-string-constants.rkt")
(prefix korean: "korean-string-constants.ss")) (prefix korean: "korean-string-constants.rkt"))
(require mzlib/file (require mzlib/file
mzlib/etc mzlib/etc
"private/only-once.ss") "private/only-once.rkt")
(provide string-constant string-constants this-language all-languages set-language-pref) (provide string-constant string-constants this-language all-languages set-language-pref)
;; set-language-pref : symbol -> void ;; set-language-pref : symbol -> void
(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)) ;; table : (listof (list symbol regexp regexp))
;; this table indicates what the default value of the natural language ;; this table indicates what the default value of the natural language
;; preference is. the first regexp is used under Windows and the second ;; preference is. the first regexp is used under Windows and the second
;; is used on other platforms. All regexps are compared to the result ;; is used on other platforms. All regexps are compared to the result
;; of (system-language+country) ;; of (system-language+country)
(define table (define table
'((english #rx"^en_" #rx"^English_") '((english #rx"^en_" #rx"^English_")
(spanish #rx"^es_" #rx"^Espanol_") (spanish #rx"^es_" #rx"^Espanol_")
(german #rx"^de_" #rx"^German_") (german #rx"^de_" #rx"^German_")
@ -46,29 +45,27 @@
(ukrainian #rx"^uk_" #rx"^Ukrainian_") (ukrainian #rx"^uk_" #rx"^Ukrainian_")
(korean #rx"^ko_" #rx"^Korean_"))) (korean #rx"^ko_" #rx"^Korean_")))
;; default-language : -> symbol ;; default-language : -> symbol
;; uses `table' and system-language+contry to find what language to start with ;; uses `table' and system-language+contry to find what language to start with
(define (default-language) (define (default-language)
(let ([slc (system-language+country)]) (let ([slc (system-language+country)])
(let loop ([table table]) (let loop ([table table])
(cond (if (null? table)
[(null? table) 'english
'english]
[else
(let ([ent (car table)]) (let ([ent (car table)])
(if (or (regexp-match (cadr ent) slc) (if (or (regexp-match (cadr ent) slc)
(and (cddr ent) (and (cddr ent)
(regexp-match (caddr ent) slc))) (regexp-match (caddr ent) slc)))
(car ent) (car ent)
(loop (cdr table))))])))) (loop (cdr table))))))))
;; language : symbol ;; language : symbol
(define language (define language
(with-handlers ([exn:fail? (lambda (_) (default-language))]) (with-handlers ([exn:fail? (lambda (_) (default-language))])
(get-preference 'plt:human-language (lambda () (default-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]))
(define-struct sc (language-name constants ht)) (define-struct sc (language-name constants ht))
@ -99,8 +96,7 @@
;; (again, according to read) you get those languages. ;; (again, according to read) you get those languages.
;; if it is set to anything else, you get all languages. ;; if it is set to anything else, you get all languages.
(define (env-var-set? lang) (define (env-var-set? lang)
(cond (cond [(symbol? specific) (eq? lang specific)]
[(symbol? specific) (eq? lang specific)]
[(list? specific) (memq lang specific)] [(list? specific) (memq lang specific)]
[else #t])) [else #t]))
@ -169,11 +165,8 @@
(fprintf sp "WARNING: language ~a had but ~a does not:\n" (fprintf sp "WARNING: language ~a had but ~a does not:\n"
lang1-name lang1-name
lang2-name) lang2-name)
(for-each (for-each (lambda (x) (fprintf sp " ~s\n" x))
(lambda (x) (fprintf sp " ~s\n" x)) (sort constants string<=? #:key symbol->string #:cache-keys? #t))
(sort
constants
(lambda (x y) (string<=? (symbol->string (car x)) (symbol->string (car y))))))
(newline sp))) (newline sp)))
warning-table) warning-table)
(get-output-string sp))))) (get-output-string sp)))))
@ -185,33 +178,32 @@
(let ([assoc-table (sc-constants first-string-constant-set)] (let ([assoc-table (sc-constants first-string-constant-set)]
[datum (syntax-object->datum (syntax name))]) [datum (syntax-object->datum (syntax name))])
(unless (symbol? datum) (unless (symbol? datum)
(raise-syntax-error #f (raise-syntax-error #f (format "expected name, got: ~s" datum) stx))
(format "expected name, got: ~s" datum)
stx))
(let ([default-val (assq datum assoc-table)]) (let ([default-val (assq datum assoc-table)])
(unless default-val (unless default-val
(raise-syntax-error (raise-syntax-error
#f #f
(format "~a is not a known string constant" datum) (format "~a is not a known string constant" datum)
stx)) stx))
(with-syntax ([(constants ...) (map (lambda (x) (with-syntax ([(constants ...)
(map (lambda (x)
(let ([val (assq datum (sc-constants x))]) (let ([val (assq datum (sc-constants x))])
(if val (if val
(cadr val) (cadr val)
(cadr default-val)))) (cadr default-val))))
available-string-constant-sets)] available-string-constant-sets)]
[(languages ...) (map sc-language-name available-string-constant-sets)] [(languages ...)
[first-constant (cadr (assq datum (sc-constants first-string-constant-set)))]) (map sc-language-name available-string-constant-sets)]
[first-constant
(cadr (assq datum (sc-constants first-string-constant-set)))])
(with-syntax ([conditional-for-string (with-syntax ([conditional-for-string
(syntax/loc stx (syntax/loc stx
(cond (cond [(eq? language 'languages) constants] ...
[(eq? language 'languages) constants] ...
[else first-constant]))]) [else first-constant]))])
(if env-var-set (if env-var-set
(with-syntax ([warning-message (get-warning-message)]) (with-syntax ([warning-message (get-warning-message)])
(syntax/loc stx (syntax/loc stx
(begin (begin (maybe-print-message warning-message)
(maybe-print-message warning-message)
conditional-for-string))) conditional-for-string)))
(syntax/loc stx conditional-for-string))))))])) (syntax/loc stx conditional-for-string))))))]))
@ -221,16 +213,15 @@
(let ([assoc-table (sc-constants first-string-constant-set)] (let ([assoc-table (sc-constants first-string-constant-set)]
[datum (syntax-object->datum (syntax name))]) [datum (syntax-object->datum (syntax name))])
(unless (symbol? datum) (unless (symbol? datum)
(raise-syntax-error #f (raise-syntax-error #f (format "expected name, got: ~s" datum) stx))
(format "expected name, got: ~s" datum)
stx))
(let ([default-val (assq datum assoc-table)]) (let ([default-val (assq datum assoc-table)])
(unless default-val (unless default-val
(raise-syntax-error (raise-syntax-error
#f #f
(format "~a is not a known string constant" datum) (format "~a is not a known string constant" datum)
stx)) stx))
(with-syntax ([(constants ...) (map (lambda (x) (with-syntax ([(constants ...)
(map (lambda (x)
(let ([val (assq datum (sc-constants x))]) (let ([val (assq datum (sc-constants x))])
(if val (if val
(cadr val) (cadr val)
@ -239,15 +230,15 @@
(syntax (list constants ...)))))])) (syntax (list constants ...)))))]))
(define (this-language/proc stx) (define (this-language/proc stx)
(syntax-case stx () (syntax-case stx () [(_) (syntax language)]))
[(_)
(syntax language)]))
(define (all-languages/proc stx) (define (all-languages/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_) [(_)
(with-syntax ([(languages ...) (map sc-language-name available-string-constant-sets)]) (with-syntax ([(languages ...)
(syntax (list 'languages ...)))])))) (map sc-language-name available-string-constant-sets)])
(syntax (list 'languages ...)))])))
#| #|
(require string-constant) (require string-constant)
(string-constant is-this-your-native-language) (string-constant is-this-your-native-language)