1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
(module localization racket/base
(require racket/contract/base
racket/file
(only-in racket/runtime-path define-runtime-path)
racket/string racket/format
syntax/modread
(for-syntax racket/base))
(provide/contract (current-language (parameter/c symbol?))
(current-country (parameter/c symbol?))
(current-locale-details (parameter/c (listof symbol?)))
(declare-bundle! (-> (listof symbol?) (listof pair?) any))
(load-bundle! (->* ((listof symbol?)) #:rest any/c any))
(store-bundle! (-> (listof symbol?) any))
(localized-template (-> symbol? any/c any)))
(provide re-read-locale)
(define get-from-locale
(lambda (what)
(let ((locale (current-locale)))
(if (string=? locale "")
(case what
((language) 'en) ;; Default language: English
((country) 'us) ;; Default country: US
(else null))
(let ((len (string-length locale)))
(case what
((language)
(if (>= len 2)
(string->symbol (substring locale 0 2))
'en))
((country)
(if (>= len 5)
(string->symbol (substring locale 3 5))
'us))
(else ;; details
(if (> len 6)
(list (string->symbol (substring locale 6)))
null))))))))
;; The association list in which bundles will be stored
(define *localization-bundles*
(make-hash))
(define current-language
(make-parameter (get-from-locale 'language)))
(define current-country
(make-parameter (get-from-locale 'country)))
(define current-locale-details
(make-parameter (get-from-locale 'details)))
(define (make-name bundle-specifier)
(string->symbol
(string-append "srfi-29:"
(~v bundle-specifier))))
(define (declare-bundle! bundle-specifier bundle-assoc-list)
(hash-set! *localization-bundles* bundle-specifier bundle-assoc-list))
(define (store-bundle! bundle-specifier)
(put-preferences (list (make-name bundle-specifier))
(list (hash-ref *localization-bundles* bundle-specifier)))
#t)
(define (load-bundle-from-preference! bundle-specifier)
(let/ec k
(declare-bundle! bundle-specifier
(get-preference (make-name bundle-specifier)
(lambda () (k #f))))
#t))
;; If you change (current-locale), you don't have to set current-*
;; by hand, you can simply call this procedure, and it will update
;; those parameters to the values in the new locale.
(define (re-read-locale)
(current-language (get-from-locale 'language))
(current-country (get-from-locale 'country))
(current-locale-details (get-from-locale 'details)))
;; System bundles are here:
(define-runtime-path system-bundles "bundles")
(define (with-reader-params thunk)
;; Use `with-module-reading-parameterization' to get
;; most defaults...
(with-module-reading-parameterization
(lambda ()
;; ... but disable `#reader':
(parameterize ([read-accept-reader #f])
(thunk)))))
;; load-bundle! accpect an alternate-path to search bundle
(define (load-bundle! bundle-specifier . alternate-path)
(or (load-bundle-from-preference! bundle-specifier)
(let* ((filename (case (length bundle-specifier)
((1) (symbol->string (car bundle-specifier)))
((2) (build-path (symbol->string (cadr bundle-specifier))
(symbol->string (car bundle-specifier))))
(else (build-path (symbol->string (cadr bundle-specifier))
(symbol->string (caddr bundle-specifier))
(symbol->string (car bundle-specifier))))))
(path (build-path (if (null? alternate-path)
system-bundles
(car alternate-path))
filename)))
(and (file-exists? path)
(declare-bundle! bundle-specifier
(with-reader-params
(lambda ()
(with-input-from-file path read))))
#t))))
(define (rdc ls)
(if (null? (cdr ls))
'()
(cons (car ls) (rdc (cdr ls)))))
;;Retrieve a localized template given its package name and a template name
(define (localized-template package-name template-name)
(let loop ((specifier (list package-name
(current-language)
(current-country))))
(and (not (null? specifier))
(let ((bundle (hash-ref *localization-bundles* specifier #f)))
(cond ((and bundle (assq template-name bundle)) => cdr)
((null? (cdr specifier)) #f)
(else (loop (rdc specifier))))))))
)
|
