diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt index 8bcde0a4ee..6391efac22 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt @@ -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%)]) diff --git a/pkgs/gui-pkgs/gui-doc/string-constants/string-constants.scrbl b/pkgs/gui-pkgs/gui-doc/string-constants/string-constants.scrbl index d05ff80ed9..4026729af3 100644 --- a/pkgs/gui-pkgs/gui-doc/string-constants/string-constants.scrbl +++ b/pkgs/gui-pkgs/gui-doc/string-constants/string-constants.scrbl @@ -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.} diff --git a/pkgs/string-constants-lib/string-constants/private/string-constant-lang.rkt b/pkgs/string-constants-lib/string-constants/private/string-constant-lang.rkt index 4e41f212c9..9d57e8ee7f 100644 --- a/pkgs/string-constants-lib/string-constants/private/string-constant-lang.rkt +++ b/pkgs/string-constants-lib/string-constants/private/string-constant-lang.rkt @@ -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)]) diff --git a/pkgs/string-constants-lib/string-constants/string-constant.rkt b/pkgs/string-constants-lib/string-constants/string-constant.rkt index f4a5fca555..fd7e730b43 100644 --- a/pkgs/string-constants-lib/string-constants/string-constant.rkt +++ b/pkgs/string-constants-lib/string-constants/string-constant.rkt @@ -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)) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt index 7c01314a02..0c8d6f1aeb 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt @@ -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)