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

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

@ -1,253 +1,244 @@
#lang mzscheme
(require-for-syntax mzlib/etc
mzlib/list
(prefix english: "english-string-constants.rkt")
(prefix spanish: "spanish-string-constants.rkt")
(prefix german: "german-string-constants.rkt")
(prefix french: "french-string-constants.rkt")
(prefix dutch: "dutch-string-constants.rkt")
(prefix danish: "danish-string-constants.rkt")
(prefix portuguese: "portuguese-string-constants.rkt")
(prefix japanese: "japanese-string-constants.rkt")
(prefix traditional-chinese: "traditional-chinese-string-constants.rkt")
(prefix simplified-chinese: "simplified-chinese-string-constants.rkt")
(prefix russian: "russian-string-constants.rkt")
(prefix ukrainian: "ukrainian-string-constants.rkt")
(prefix korean: "korean-string-constants.rkt"))
(module string-constant mzscheme (require mzlib/file
(require-for-syntax mzlib/etc mzlib/etc
mzlib/list "private/only-once.rkt")
(prefix english: "english-string-constants.ss")
(prefix spanish: "spanish-string-constants.ss")
(prefix german: "german-string-constants.ss")
(prefix french: "french-string-constants.ss")
(prefix dutch: "dutch-string-constants.ss")
(prefix danish: "danish-string-constants.ss")
(prefix portuguese: "portuguese-string-constants.ss")
(prefix japanese: "japanese-string-constants.ss")
(prefix traditional-chinese: "traditional-chinese-string-constants.ss")
(prefix simplified-chinese: "simplified-chinese-string-constants.ss")
(prefix russian: "russian-string-constants.ss")
(prefix ukrainian: "ukrainian-string-constants.ss")
(prefix korean: "korean-string-constants.ss"))
(require mzlib/file (provide string-constant string-constants this-language all-languages set-language-pref)
mzlib/etc
"private/only-once.ss")
(provide string-constant string-constants this-language all-languages set-language-pref) ;; set-language-pref : symbol -> void
(define (set-language-pref language)
(put-preferences (list 'plt:human-language) (list language)))
;; set-language-pref : symbol -> void ;; table : (listof (list symbol regexp regexp))
(define (set-language-pref language) ;; this table indicates what the default value of the natural language
(put-preferences (list 'plt:human-language) (list language))) ;; preference is. the first regexp is used under Windows and the second
;; is used on other platforms. 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)")
(russian #rx"^ru_" #rx"^Russian_")
(ukrainian #rx"^uk_" #rx"^Ukrainian_")
(korean #rx"^ko_" #rx"^Korean_")))
;; table : (listof (list symbol regexp regexp)) ;; default-language : -> symbol
;; this table indicates what the default value of the natural language ;; uses `table' and system-language+contry to find what language to start with
;; preference is. the first regexp is used under Windows and the second (define (default-language)
;; is used on other platforms. All regexps are compared to the result (let ([slc (system-language+country)])
;; of (system-language+country) (let loop ([table table])
(define table (if (null? table)
'((english #rx"^en_" #rx"^English_") 'english
(spanish #rx"^es_" #rx"^Espanol_") (let ([ent (car table)])
(german #rx"^de_" #rx"^German_") (if (or (regexp-match (cadr ent) slc)
(french #rx"^fr_" #rx"French_") (and (cddr ent)
(dutch #rx"nl_" #rx"^Netherlands_") (regexp-match (caddr ent) slc)))
(danish #rx"^da_DK" #rx"^Danish_") (car ent)
(portuguese #rx"^pt_" #rx"Portuguese_") (loop (cdr table))))))))
(japanese #rx"^ja_" #rx"^Japan_")
(traditional-chinese #rx"^zh_(HK|TW)" #rx"Chinese_China")
(simplified-chinese #rx"^zh_CN" #rx"Chinese_(Hong|Taiwan)")
(russian #rx"^ru_" #rx"^Russian_")
(ukrainian #rx"^uk_" #rx"^Ukrainian_")
(korean #rx"^ko_" #rx"^Korean_")))
;; 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 (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))
(define available-string-constant-sets (define available-string-constant-sets
(list (list
(make-sc 'english english:string-constants #f) (make-sc 'english english:string-constants #f)
(make-sc 'spanish spanish:string-constants #f) (make-sc 'spanish spanish:string-constants #f)
(make-sc 'french french:string-constants #f) (make-sc 'french french:string-constants #f)
(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 '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)
(make-sc 'simplified-chinese simplified-chinese:string-constants #f) (make-sc 'simplified-chinese simplified-chinese:string-constants #f)
(make-sc 'russian russian:string-constants #f) (make-sc 'russian russian:string-constants #f)
(make-sc 'ukrainian ukrainian:string-constants #f) (make-sc 'ukrainian ukrainian:string-constants #f)
(make-sc 'korean korean:string-constants #f))) (make-sc 'korean korean:string-constants #f)))
(define first-string-constant-set (car available-string-constant-sets)) (define first-string-constant-set (car available-string-constant-sets))
;; env-var-set? : symbol -> boolean ;; env-var-set? : symbol -> boolean
;; returns #t if the user has requested this langage info. ;; returns #t if the user has requested this langage info.
;; If the environment variable is set to something that ;; If the environment variable is set to something that
;; isn't well-formed according to `read' you get all output ;; isn't well-formed according to `read' you get all output
;; If the environment variable is set to a symbol (according to read) ;; If the environment variable is set to a symbol (according to read)
;; you get that language. If it is set to a list of symbols ;; you get that language. If it is set to a list of symbols
;; (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]))
(define env-var-set (define env-var-set
(or (getenv "PLTSTRINGCONSTANTS") (or (getenv "PLTSTRINGCONSTANTS")
(getenv "STRINGCONSTANTS"))) (getenv "STRINGCONSTANTS")))
(define specific (define specific
(and env-var-set (and env-var-set
(with-handlers ([exn:fail:read? (lambda (x) #t)]) (with-handlers ([exn:fail:read? (lambda (x) #t)])
(read (open-input-string env-var-set))))) (read (open-input-string env-var-set)))))
(define the-warning-message #f) (define the-warning-message #f)
(define (get-warning-message) (define (get-warning-message)
(unless the-warning-message (unless the-warning-message
(set! the-warning-message (set! the-warning-message
(let* (;; type no-warning-cache-key = (cons symbol symbol) (let* (;; type no-warning-cache-key = (cons symbol symbol)
;; warning-table : (listof (list no-warning-cache-key (listof (list sym string)))) ;; warning-table : (listof (list no-warning-cache-key (listof (list sym string))))
[warning-table null] [warning-table null]
[extract-ht [extract-ht
(lambda (sc) (lambda (sc)
(unless (sc-ht sc) (unless (sc-ht sc)
(let ([ht (make-hash-table)]) (let ([ht (make-hash-table)])
(for-each (lambda (ent) (hash-table-put! ht (car ent) #t)) (for-each (lambda (ent) (hash-table-put! ht (car ent) #t))
(sc-constants sc)) (sc-constants sc))
(set-sc-ht! sc ht))) (set-sc-ht! sc ht)))
(sc-ht sc))] (sc-ht sc))]
[check-one-way [check-one-way
(lambda (sc1 sc2) (lambda (sc1 sc2)
(let ([assoc1 (sc-constants sc1)] (let ([assoc1 (sc-constants sc1)]
[assoc2 (sc-constants sc2)] [assoc2 (sc-constants sc2)]
[ht2 (extract-ht sc2)]) [ht2 (extract-ht sc2)])
(for-each (for-each
(lambda (pair1) (lambda (pair1)
(let* ([constant1 (car pair1)] (let* ([constant1 (car pair1)]
[value1 (cadr pair1)] [value1 (cadr pair1)]
[pair2 (hash-table-get ht2 constant1 (lambda () #f))]) [pair2 (hash-table-get ht2 constant1 (lambda () #f))])
(unless pair2 (unless pair2
(let ([no-warning-cache-key (cons (sc-language-name sc1) (sc-language-name sc2))]) (let ([no-warning-cache-key (cons (sc-language-name sc1) (sc-language-name sc2))])
(when (or (env-var-set? (sc-language-name sc1)) (when (or (env-var-set? (sc-language-name sc1))
(env-var-set? (sc-language-name sc2))) (env-var-set? (sc-language-name sc2)))
(cond (cond
[(memf (lambda (ent) (equal? (mcar ent) no-warning-cache-key)) warning-table) [(memf (lambda (ent) (equal? (mcar ent) no-warning-cache-key)) warning-table)
=> =>
(lambda (x) (lambda (x)
(let ([ent (car x)]) (let ([ent (car x)])
(set-mcdr! ent (cons (list constant1 value1) (mcdr ent)))))] (set-mcdr! ent (cons (list constant1 value1) (mcdr ent)))))]
[else [else
(set! warning-table (cons (mcons no-warning-cache-key (set! warning-table (cons (mcons no-warning-cache-key
(list (list constant1 value1))) (list (list constant1 value1)))
warning-table))])))))) warning-table))]))))))
assoc1)))]) assoc1)))])
(for-each (lambda (x) (for-each (lambda (x)
(check-one-way x first-string-constant-set) (check-one-way x first-string-constant-set)
(check-one-way first-string-constant-set x)) (check-one-way first-string-constant-set x))
(cdr available-string-constant-sets)) (cdr available-string-constant-sets))
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])
(for-each (for-each
(lambda (bad) (lambda (bad)
(let* ([lang-pair (mcar bad)] (let* ([lang-pair (mcar bad)]
[constants (mcdr bad)] [constants (mcdr bad)]
[lang1-name (car lang-pair)] [lang1-name (car lang-pair)]
[lang2-name (cdr lang-pair)]) [lang2-name (cdr lang-pair)])
(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 (newline sp)))
constants warning-table)
(lambda (x y) (string<=? (symbol->string (car x)) (symbol->string (car y)))))) (get-output-string sp)))))
(newline sp))) the-warning-message)
warning-table)
(get-output-string sp)))))
the-warning-message)
(define (string-constant/proc stx) (define (string-constant/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ name) [(_ name)
(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) (let ([default-val (assq datum assoc-table)])
stx)) (unless default-val
(let ([default-val (assq datum assoc-table)]) (raise-syntax-error
(unless default-val #f
(raise-syntax-error (format "~a is not a known string constant" datum)
#f stx))
(format "~a is not a known string constant" datum) (with-syntax ([(constants ...)
stx)) (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 ...)
[(languages ...) (map sc-language-name available-string-constant-sets)] (map sc-language-name available-string-constant-sets)]
[first-constant (cadr (assq datum (sc-constants first-string-constant-set)))]) [first-constant
(with-syntax ([conditional-for-string (cadr (assq datum (sc-constants first-string-constant-set)))])
(syntax/loc stx (with-syntax ([conditional-for-string
(cond (syntax/loc stx
[(eq? language 'languages) constants] ... (cond [(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))))))]))
(define (string-constants/proc stx) (define (string-constants/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ name) [(_ name)
(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) (let ([default-val (assq datum assoc-table)])
stx)) (unless default-val
(let ([default-val (assq datum assoc-table)]) (raise-syntax-error
(unless default-val #f
(raise-syntax-error (format "~a is not a known string constant" datum)
#f stx))
(format "~a is not a known string constant" datum) (with-syntax ([(constants ...)
stx)) (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)]) (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)
(syntax-case stx ()
[(_)
(with-syntax ([(languages ...)
(map sc-language-name available-string-constant-sets)])
(syntax (list 'languages ...)))])))
(define (all-languages/proc stx)
(syntax-case stx ()
[(_)
(with-syntax ([(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)