clean up string-constants expansion and add dynamic-string-constant[s]
This saves about 200 bytes per use of (string-constant ...) in the .zo file. Also, it now only requires a single string-constants file in phase 1 (instead of all 13) so that should be a savings of memory and time when compiling .zos, too.
This commit is contained in:
Robby Findler
parent
85770c3cf2
commit
2ac73eee39
|
|
@ -3,8 +3,7 @@
|
|||
(require typed/mred/mred
|
||||
typed/framework/framework
|
||||
racket/class
|
||||
string-constants/string-constant)
|
||||
|
||||
string-constants)
|
||||
|
||||
(define-type-alias Bitmap-Message% (Class ()
|
||||
([parent (Instance Horizontal-Panel%)])
|
||||
|
|
|
|||
|
|
@ -22,7 +22,19 @@ This form returns the string constant named @racket[name].}
|
|||
|
||||
This form returns a list of string constants, one for each language
|
||||
that DrRacket's GUI supports.}
|
||||
|
||||
|
||||
@defproc[(dynamic-string-constant [name symbol?]) string?]{
|
||||
This, like @racket[string-constant], returns the string constant
|
||||
named @racket[name], but without any compile-time checking on the
|
||||
argument.
|
||||
}
|
||||
|
||||
@defproc[(dynamic-string-constants [name symbol?]) (listof string?)]{
|
||||
This, like @racket[string-constants], returns the string constants
|
||||
matching @racket[name], but without any compile-time checking on the
|
||||
argument.
|
||||
}
|
||||
|
||||
@defform[(this-language)]{
|
||||
|
||||
This form returns the name of the current language as a symbol.}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
(require (for-syntax racket/base))
|
||||
|
||||
(provide (rename-out [-#%module-begin #%module-begin])
|
||||
#%datum)
|
||||
#%datum
|
||||
#%top-interaction)
|
||||
|
||||
(define-syntax (-#%module-begin stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -38,7 +39,7 @@
|
|||
(#%plain-module-begin
|
||||
(provide string-constants)
|
||||
(define string-constants
|
||||
(list (list 'name (string-append strs ...)) ...))))))]
|
||||
(make-hash (list (cons 'name (string-append strs ...)) ...)))))))]
|
||||
[(_ prs ...)
|
||||
(for ([pr-stx (in-list (syntax->list (syntax (prs ...))))])
|
||||
(let ([pr (syntax->datum pr-stx)])
|
||||
|
|
|
|||
|
|
@ -1,26 +1,28 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax mzlib/etc)
|
||||
(for-syntax mzlib/list)
|
||||
(for-syntax (prefix-in english: "private/english-string-constants.rkt"))
|
||||
(for-syntax (prefix-in spanish: "private/spanish-string-constants.rkt"))
|
||||
(for-syntax (prefix-in german: "private/german-string-constants.rkt"))
|
||||
(for-syntax (prefix-in french: "private/french-string-constants.rkt"))
|
||||
(for-syntax (prefix-in dutch: "private/dutch-string-constants.rkt"))
|
||||
(for-syntax (prefix-in danish: "private/danish-string-constants.rkt"))
|
||||
(for-syntax (prefix-in portuguese: "private/portuguese-string-constants.rkt"))
|
||||
(for-syntax (prefix-in japanese: "private/japanese-string-constants.rkt"))
|
||||
(for-syntax (prefix-in traditional-chinese: "private/traditional-chinese-string-constants.rkt"))
|
||||
(for-syntax (prefix-in simplified-chinese: "private/simplified-chinese-string-constants.rkt"))
|
||||
(for-syntax (prefix-in russian: "private/russian-string-constants.rkt"))
|
||||
(for-syntax (prefix-in ukrainian: "private/ukrainian-string-constants.rkt"))
|
||||
(for-syntax (prefix-in korean: "private/korean-string-constants.rkt")))
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
(prefix-in english-ct: "private/english-string-constants.rkt"))
|
||||
racket/file
|
||||
racket/contract/base
|
||||
(prefix-in english: "private/english-string-constants.rkt")
|
||||
(prefix-in spanish: "private/spanish-string-constants.rkt")
|
||||
(prefix-in german: "private/german-string-constants.rkt")
|
||||
(prefix-in french: "private/french-string-constants.rkt")
|
||||
(prefix-in dutch: "private/dutch-string-constants.rkt")
|
||||
(prefix-in danish: "private/danish-string-constants.rkt")
|
||||
(prefix-in portuguese: "private/portuguese-string-constants.rkt")
|
||||
(prefix-in japanese: "private/japanese-string-constants.rkt")
|
||||
(prefix-in traditional-chinese: "private/traditional-chinese-string-constants.rkt")
|
||||
(prefix-in simplified-chinese: "private/simplified-chinese-string-constants.rkt")
|
||||
(prefix-in russian: "private/russian-string-constants.rkt")
|
||||
(prefix-in ukrainian: "private/ukrainian-string-constants.rkt")
|
||||
(prefix-in korean: "private/korean-string-constants.rkt"))
|
||||
|
||||
(require mzlib/file
|
||||
mzlib/etc
|
||||
"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)
|
||||
(provide/contract
|
||||
[dynamic-string-constant (-> symbol? string?)]
|
||||
[dynamic-string-constants (-> symbol? (listof string?))])
|
||||
|
||||
;; set-language-pref : symbol -> void
|
||||
(define (set-language-pref language)
|
||||
|
|
@ -60,186 +62,175 @@
|
|||
(car ent)
|
||||
(loop (cdr table))))))))
|
||||
|
||||
(define-struct sc (language-name constants [ht #:mutable]))
|
||||
|
||||
(define available-string-constant-sets
|
||||
(list
|
||||
(make-sc 'english english:string-constants #f)
|
||||
(make-sc 'spanish spanish:string-constants #f)
|
||||
(make-sc 'french french:string-constants #f)
|
||||
(make-sc 'german german:string-constants #f)
|
||||
(make-sc 'dutch dutch:string-constants #f)
|
||||
(make-sc 'danish danish:string-constants #f)
|
||||
(make-sc 'portuguese portuguese:string-constants #f)
|
||||
(make-sc 'japanese japanese:string-constants #f)
|
||||
(make-sc 'traditional-chinese traditional-chinese:string-constants #f)
|
||||
(make-sc 'simplified-chinese simplified-chinese:string-constants #f)
|
||||
(make-sc 'russian russian:string-constants #f)
|
||||
(make-sc 'ukrainian ukrainian:string-constants #f)
|
||||
(make-sc 'korean korean:string-constants #f)))
|
||||
|
||||
(define first-string-constant-set (car available-string-constant-sets))
|
||||
|
||||
;; language : symbol
|
||||
(define language
|
||||
(with-handlers ([exn:fail? (lambda (_) (default-language))])
|
||||
(get-preference 'plt:human-language (lambda () (default-language)))))
|
||||
|
||||
(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]))
|
||||
(define-struct sc (language-name constants ht) #:mutable)
|
||||
(define the-sc
|
||||
(or (for/or ([sc (in-list available-string-constant-sets)])
|
||||
(and (equal? language (sc-language-name sc))
|
||||
sc))
|
||||
first-string-constant-set))
|
||||
|
||||
(define available-string-constant-sets
|
||||
(list
|
||||
(make-sc 'english english:string-constants #f)
|
||||
(make-sc 'spanish spanish:string-constants #f)
|
||||
(make-sc 'french french:string-constants #f)
|
||||
(make-sc 'german german:string-constants #f)
|
||||
(make-sc 'dutch dutch:string-constants #f)
|
||||
(make-sc 'danish danish:string-constants #f)
|
||||
(make-sc 'portuguese portuguese:string-constants #f)
|
||||
(make-sc 'japanese japanese:string-constants #f)
|
||||
(make-sc 'traditional-chinese traditional-chinese:string-constants #f)
|
||||
(make-sc 'simplified-chinese simplified-chinese:string-constants #f)
|
||||
(make-sc 'russian russian:string-constants #f)
|
||||
(make-sc 'ukrainian ukrainian:string-constants #f)
|
||||
(make-sc 'korean korean:string-constants #f)))
|
||||
(define (dynamic-string-constant key)
|
||||
(dynamic-string-constant/who key 'dynamic-string-constant))
|
||||
|
||||
(define first-string-constant-set (car available-string-constant-sets))
|
||||
(define (dynamic-string-constants key)
|
||||
(for/list ([sc (in-list available-string-constant-sets)])
|
||||
(dynamic-string-constant sc 'dynamic-string-constants)))
|
||||
|
||||
;; env-var-set? : symbol -> boolean
|
||||
;; returns #t if the user has requested this langage info.
|
||||
;; If the environment variable is set to something that
|
||||
;; isn't well-formed according to `read' you get all output
|
||||
;; 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
|
||||
;; (again, according to read) you get those languages.
|
||||
;; if it is set to anything else, you get all languages.
|
||||
(define (env-var-set? lang)
|
||||
(cond [(symbol? specific) (eq? lang specific)]
|
||||
[(list? specific) (memq lang specific)]
|
||||
[else #t]))
|
||||
(define (dynamic-string-constant/who key who)
|
||||
(hash-ref (sc-constants the-sc) key
|
||||
(λ ()
|
||||
(hash-ref (sc-constants first-string-constant-set)
|
||||
key
|
||||
(λ ()
|
||||
(error who
|
||||
"unknown string-constant\n key: ~e" key))))))
|
||||
|
||||
(define env-var-set
|
||||
(or (getenv "PLTSTRINGCONSTANTS")
|
||||
(getenv "STRINGCONSTANTS")))
|
||||
(define already-warned? #f)
|
||||
(define (show-warning-message)
|
||||
(unless already-warned?
|
||||
(set! already-warned? #t)
|
||||
(define the-warning-message
|
||||
(let* (;; type no-warning-cache-key = (cons symbol symbol)
|
||||
;; warning-table : (listof (list no-warning-cache-key (listof (list sym string))))
|
||||
[warning-table null]
|
||||
[extract-ht
|
||||
(lambda (sc)
|
||||
(unless (sc-ht sc)
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (lambda (ent) (hash-set! ht (car ent) #t))
|
||||
(sc-constants sc))
|
||||
(set-sc-ht! sc ht)))
|
||||
(sc-ht sc))]
|
||||
[check-one-way
|
||||
(lambda (sc1 sc2)
|
||||
(let ([assoc1 (sc-constants sc1)]
|
||||
[assoc2 (sc-constants sc2)]
|
||||
[ht2 (extract-ht sc2)])
|
||||
(for-each
|
||||
(lambda (pair1)
|
||||
(let* ([constant1 (car pair1)]
|
||||
[value1 (cadr pair1)]
|
||||
[pair2 (hash-ref ht2 constant1 (lambda () #f))])
|
||||
(unless pair2
|
||||
(let ([no-warning-cache-key (cons (sc-language-name sc1)
|
||||
(sc-language-name sc2))])
|
||||
(when (or (env-var-set? (sc-language-name sc1))
|
||||
(env-var-set? (sc-language-name sc2)))
|
||||
(cond
|
||||
[(memf (lambda (ent) (equal? (mcar ent) no-warning-cache-key))
|
||||
warning-table)
|
||||
=>
|
||||
(lambda (x)
|
||||
(let ([ent (car x)])
|
||||
(set-mcdr! ent (cons (list constant1 value1) (mcdr ent)))))]
|
||||
[else
|
||||
(set! warning-table (cons (mcons no-warning-cache-key
|
||||
(list (list constant1 value1)))
|
||||
warning-table))]))))))
|
||||
assoc1)))])
|
||||
|
||||
(for-each (lambda (x)
|
||||
(check-one-way x first-string-constant-set)
|
||||
(check-one-way first-string-constant-set x))
|
||||
(cdr available-string-constant-sets))
|
||||
|
||||
(let ([sp (open-output-string)])
|
||||
(for-each
|
||||
(lambda (bad)
|
||||
(let* ([lang-pair (mcar bad)]
|
||||
[constants (mcdr bad)]
|
||||
[lang1-name (car lang-pair)]
|
||||
[lang2-name (cdr lang-pair)])
|
||||
(fprintf sp "WARNING: language ~a had but ~a does not:\n"
|
||||
lang1-name
|
||||
lang2-name)
|
||||
(for-each (lambda (x) (fprintf sp " ~s\n" x))
|
||||
(sort constants string<=?
|
||||
#:key (lambda (p)
|
||||
(symbol->string (car p)))
|
||||
#:cache-keys? #t))
|
||||
(newline sp)))
|
||||
warning-table)
|
||||
(get-output-string sp))))
|
||||
|
||||
(with-handlers ([exn:fail? (lambda (x) (void))])
|
||||
;; the output port may no longer be there, in which case
|
||||
;; we just give up on printing
|
||||
(eprintf "~a" the-warning-message))))
|
||||
|
||||
(define specific
|
||||
(and env-var-set
|
||||
(with-handlers ([exn:fail:read? (lambda (x) #t)])
|
||||
(read (open-input-string env-var-set)))))
|
||||
;; env-var-set? : symbol -> boolean
|
||||
;; returns #t if the user has requested this langage info.
|
||||
;; If the environment variable is set to something that
|
||||
;; isn't well-formed according to `read' you get all output
|
||||
;; 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
|
||||
;; (again, according to read) you get those languages.
|
||||
;; if it is set to anything else, you get all languages.
|
||||
(define (env-var-set? lang)
|
||||
(cond [(symbol? specific) (eq? lang specific)]
|
||||
[(list? specific) (memq lang specific)]
|
||||
[else #t]))
|
||||
|
||||
(define the-warning-message #f)
|
||||
(define (get-warning-message)
|
||||
(unless the-warning-message
|
||||
(set! the-warning-message
|
||||
(let* (;; type no-warning-cache-key = (cons symbol symbol)
|
||||
;; warning-table : (listof (list no-warning-cache-key (listof (list sym string))))
|
||||
[warning-table null]
|
||||
[extract-ht
|
||||
(lambda (sc)
|
||||
(unless (sc-ht sc)
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (lambda (ent) (hash-set! ht (car ent) #t))
|
||||
(sc-constants sc))
|
||||
(set-sc-ht! sc ht)))
|
||||
(sc-ht sc))]
|
||||
[check-one-way
|
||||
(lambda (sc1 sc2)
|
||||
(let ([assoc1 (sc-constants sc1)]
|
||||
[assoc2 (sc-constants sc2)]
|
||||
[ht2 (extract-ht sc2)])
|
||||
(for-each
|
||||
(lambda (pair1)
|
||||
(let* ([constant1 (car pair1)]
|
||||
[value1 (cadr pair1)]
|
||||
[pair2 (hash-ref ht2 constant1 (lambda () #f))])
|
||||
(unless pair2
|
||||
(let ([no-warning-cache-key (cons (sc-language-name sc1) (sc-language-name sc2))])
|
||||
(when (or (env-var-set? (sc-language-name sc1))
|
||||
(env-var-set? (sc-language-name sc2)))
|
||||
(cond
|
||||
[(memf (lambda (ent) (equal? (mcar ent) no-warning-cache-key)) warning-table)
|
||||
=>
|
||||
(lambda (x)
|
||||
(let ([ent (car x)])
|
||||
(set-mcdr! ent (cons (list constant1 value1) (mcdr ent)))))]
|
||||
[else
|
||||
(set! warning-table (cons (mcons no-warning-cache-key
|
||||
(list (list constant1 value1)))
|
||||
warning-table))]))))))
|
||||
assoc1)))])
|
||||
(define env-var-set
|
||||
(or (getenv "PLTSTRINGCONSTANTS")
|
||||
(getenv "STRINGCONSTANTS")))
|
||||
|
||||
(for-each (lambda (x)
|
||||
(check-one-way x first-string-constant-set)
|
||||
(check-one-way first-string-constant-set x))
|
||||
(cdr available-string-constant-sets))
|
||||
(define specific
|
||||
(and env-var-set
|
||||
(with-handlers ([exn:fail:read? (lambda (x) #t)])
|
||||
(read (open-input-string env-var-set)))))
|
||||
|
||||
(let ([sp (open-output-string)])
|
||||
(for-each
|
||||
(lambda (bad)
|
||||
(let* ([lang-pair (mcar bad)]
|
||||
[constants (mcdr bad)]
|
||||
[lang1-name (car lang-pair)]
|
||||
[lang2-name (cdr lang-pair)])
|
||||
(fprintf sp "WARNING: language ~a had but ~a does not:\n"
|
||||
lang1-name
|
||||
lang2-name)
|
||||
(for-each (lambda (x) (fprintf sp " ~s\n" x))
|
||||
(sort constants string<=?
|
||||
#:key (lambda (p)
|
||||
(symbol->string (car p)))
|
||||
#:cache-keys? #t))
|
||||
(newline sp)))
|
||||
warning-table)
|
||||
(get-output-string sp)))))
|
||||
the-warning-message)
|
||||
|
||||
(define (string-constant/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(let ([assoc-table (sc-constants first-string-constant-set)]
|
||||
[datum (syntax->datum (syntax name))])
|
||||
(unless (symbol? datum)
|
||||
(raise-syntax-error #f (format "expected name, got: ~s" datum) stx))
|
||||
(let ([default-val (assq datum assoc-table)])
|
||||
(unless default-val
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "~a is not a known string constant" datum)
|
||||
stx))
|
||||
(with-syntax ([(constants ...)
|
||||
(map (lambda (x)
|
||||
(let ([val (assq datum (sc-constants x))])
|
||||
(if val
|
||||
(cadr val)
|
||||
(cadr default-val))))
|
||||
available-string-constant-sets)]
|
||||
[(languages ...)
|
||||
(map sc-language-name available-string-constant-sets)]
|
||||
[first-constant
|
||||
(cadr (assq datum (sc-constants first-string-constant-set)))])
|
||||
(with-syntax ([conditional-for-string
|
||||
(syntax/loc stx
|
||||
(cond [(eq? language 'languages) constants] ...
|
||||
[else first-constant]))])
|
||||
(if env-var-set
|
||||
(with-syntax ([warning-message (get-warning-message)])
|
||||
(syntax/loc stx
|
||||
(begin (maybe-print-message warning-message)
|
||||
conditional-for-string)))
|
||||
(syntax/loc stx conditional-for-string))))))]))
|
||||
(define-for-syntax (check-name name-stx stx)
|
||||
(define datum (syntax->datum name-stx))
|
||||
(unless (symbol? datum)
|
||||
(raise-syntax-error #f (format "expected name, got: ~s" datum) stx))
|
||||
(define default-val (hash-ref english-ct:string-constants datum #f))
|
||||
(unless default-val
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "~a is not a known string constant" datum)
|
||||
stx)))
|
||||
|
||||
(define (string-constants/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(let ([assoc-table (sc-constants first-string-constant-set)]
|
||||
[datum (syntax->datum (syntax name))])
|
||||
(unless (symbol? datum)
|
||||
(raise-syntax-error #f (format "expected name, got: ~s" datum) stx))
|
||||
(let ([default-val (assq datum assoc-table)])
|
||||
(unless default-val
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "~a is not a known string constant" datum)
|
||||
stx))
|
||||
(with-syntax ([(constants ...)
|
||||
(map (lambda (x)
|
||||
(let ([val (assq datum (sc-constants x))])
|
||||
(if val
|
||||
(cadr val)
|
||||
(cadr default-val))))
|
||||
available-string-constant-sets)])
|
||||
(syntax (list constants ...)))))]))
|
||||
(define-syntax (string-constant stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(begin
|
||||
(check-name #'name stx)
|
||||
#'(dynamic-string-constant 'name))]))
|
||||
|
||||
(define (this-language/proc stx)
|
||||
(syntax-case stx () [(_) (syntax language)]))
|
||||
(define-syntax (string-constants stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(begin
|
||||
(check-name #'name stx)
|
||||
#'(dynamic-string-constants 'name))]))
|
||||
|
||||
(define (all-languages/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(with-syntax ([(languages ...)
|
||||
(map sc-language-name available-string-constant-sets)])
|
||||
(syntax (list 'languages ...)))])))
|
||||
(define (this-language) language)
|
||||
|
||||
(define (all-languages) (map sc-language-name available-string-constant-sets))
|
||||
|
||||
|
|
|
|||
|
|
@ -30,9 +30,8 @@
|
|||
;; make-promise
|
||||
[(make-template-identifier 'delay 'racket/private/promise)
|
||||
(-poly (a) (-> (-> a) (-Promise a)))]
|
||||
;; language
|
||||
[(make-template-identifier 'language 'string-constants/string-constant)
|
||||
-Symbol]
|
||||
[(make-template-identifier 'dynamic-string-constant 'string-constants/string-constant)
|
||||
(-> -Symbol -String)]
|
||||
;; qq-append
|
||||
[(make-template-identifier 'qq-append 'racket/private/qq-and-or)
|
||||
(-poly (a b)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user