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

updates from Chongkai

Browse Source 
svn: r7034
This commit is contained in:
Matthew Flatt 2007-08-06 16:15:55 +00:00
parent 6eef897d54
commit c877c0a2d8
3 changed files with 86 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/srfi/19/time.ss
View File

@ -97,7 +97,7 @@
;; SRFI-29: Localization initialization:
(re-read-locale)
(or (load-bundle! (list 'srfi-19
(or (load-bundle! (list* 'srfi-19
(current-language)
(current-country)
(current-locale-details)))

255
collects/srfi/29/localization.ss
View File

@ -1,39 +1,21 @@
;;; <localization.ss> SRFI-29: localization port to PLT Scheme -*- Scheme -*-
;;; Time-stamp: <03/05/08 12:49:08 solsona>
;;;
;;; Copyright (C) Scott G. Miller (2002). All Rights Reserved.
;;;
;;; This file is part of PLT Scheme.
;;; PLT Scheme is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;; PLT Scheme is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with PLT Scheme; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Scott G. Miller
;;; Modified for PLT Scheme by: Francisco Solsona <solsona@acm.org>
(module localization mzscheme
(require (lib "etc.ss")
(require (lib "contract.ss")
(lib "file.ss")
(lib "runtime-path.ss")
(lib "string.ss")
(lib "modread.ss" "syntax"))
(provide current-language current-country current-locale-details
load-bundle! store-bundle! declare-bundle!
localized-template
;; NOT in SRFI-29, but useful in PLT when using/changing current-locale:
re-read-locale
)
(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?)) 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)))
@ -56,48 +38,51 @@
(if (> len 6)
(list (string->symbol (substring locale 6)))
null))))))))
(define list-of
(lambda (pred)
(lambda (lst)
(call/cc (lambda (exit)
(let loop ((lst lst))
(cond ((null? lst) #t)
(else (or (pred (car lst))
(exit #f))
(loop (cdr lst))))))))))
;; The association list in which bundles will be stored
(define *localization-bundles* '())
(define *localization-bundles*
(make-hash-table 'equal))
(define current-language
(make-parameter (get-from-locale 'language) (lambda (l)
(if (symbol? l) l 'en))))
(make-parameter (get-from-locale 'language)))
(define current-country
(make-parameter (get-from-locale 'country) (lambda (l)
(if (symbol? l) l 'us))))
(make-parameter (get-from-locale 'country)))
(define current-locale-details
(make-parameter (get-from-locale 'details) (lambda (lst)
(if ((list-of symbol?) lst)
lst
null))))
(make-parameter (get-from-locale 'details)))
(define (make-name bundle-specifier)
(string->symbol
(string-append "srfi-29:"
(expr->string bundle-specifier))))
(define (declare-bundle! bundle-specifier bundle-assoc-list)
(hash-table-put! *localization-bundles* bundle-specifier bundle-assoc-list))
(define (store-bundle! bundle-specifier)
(put-preferences (list (make-name bundle-specifier))
(list (hash-table-get *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
(lambda ()
(current-language (get-from-locale 'language))
(current-country (get-from-locale 'country))
(current-locale-details (get-from-locale 'details))))
(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...
@ -106,114 +91,40 @@
;; ... but disable `#reader':
(parameterize ([read-accept-reader #f])
(thunk)))))
;; bundle-specifier: (listof symbol)
;; i.e. package + locale, (package-name [language] [country] [details ...])
(define load-bundle!
(opt-lambda (bundle-specifier [alternate-path null])
(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
alternate-path)
filename)))
(and (file-exists? path)
;; Found!
(declare-bundle! bundle-specifier
(with-reader-params
(lambda ()
(with-input-from-file path read))))))))
(define extract-assoc-list
(lambda (bundle-specifier)
(let loop ((bundle *localization-bundles*))
(cond ((null? bundle) #f)
((equal? (caar bundle) bundle-specifier)
(cdar bundle))
(else (extract-assoc-list (cdr bundle)))))))
(define store-bundle!
(opt-lambda (bundle-specifier [alternate-path null])
(let* ((sub-path (if (null? alternate-path) system-bundles alternate-path))
(file (case (length bundle-specifier)
((1) (symbol->string (car bundle-specifier)))
((2)
(let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier))))
(file (build-path dir (symbol->string (car bundle-specifier)))))
(unless (directory-exists? dir)
(make-directory dir))
file))
(else
(let* ((dir (build-path sub-path (symbol->string (cadr bundle-specifier))))
(dir2 (build-path dir (symbol->string (caddr bundle-specifier))))
(file (build-path dir2 (symbol->string (car bundle-specifier)))))
(unless (directory-exists? dir)
(make-directory dir))
(unless (directory-exists? dir2)
(make-directory dir2))
file))))
(bundle-assoc-list (extract-assoc-list bundle-specifier)))
(and bundle-assoc-list
;; Storing bundle!
(if (file-exists? file)
(if (memq 'write (file-or-directory-permissions file))
;; Replacing the existing bundle
(with-output-to-file file (lambda ()
(write bundle-assoc-list))
'truncate/replace)
#f);; should be an exception?
(if (let-values ([(base filename directory?) (split-path file)])
(memq 'write (file-or-directory-permissions base)))
;; First time, this bundle is stored here:
(with-output-to-file file (lambda ()
(write bundle-assoc-list)))
#f))))))
;; Declare a bundle of templates with a given bundle specifier
(define declare-bundle!
(letrec ((remove-old-bundle
(lambda (specifier bundle)
(cond ((null? bundle) '())
((equal? (caar bundle) specifier)
(cdr bundle))
(else (cons (car bundle)
(remove-old-bundle specifier
(cdr bundle))))))))
(lambda (bundle-specifier bundle-assoc-list)
(set! *localization-bundles*
(cons (cons bundle-specifier bundle-assoc-list)
(remove-old-bundle bundle-specifier
*localization-bundles*))))))
;; 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
(letrec ((rdc
(lambda (ls)
(if (null? (cdr ls))
'()
(cons (car ls) (rdc (cdr ls))))))
(find-bundle
(lambda (specifier template-name)
(cond ((assoc specifier *localization-bundles*) =>
(lambda (bundle) bundle))
((null? specifier) #f)
(else (find-bundle (rdc specifier)
template-name))))))
(lambda (package-name template-name)
(let loop ((specifier (cons package-name
(list (current-language)
(current-country)))))
(and (not (null? specifier))
(let ((bundle (find-bundle specifier template-name)))
(and bundle
(cond ((assq template-name bundle) => cdr)
((null? (cdr specifier)) #f)
(else (loop (rdc specifier)))))))))))
)
(define (localized-template package-name template-name)
(let loop ((specifier (list package-name
(current-language)
(current-country))))
(and (not (null? specifier))
(let ((bundle (hash-table-get *localization-bundles* specifier #f)))
(cond ((and bundle (assq template-name bundle)) => cdr)
((null? (cdr specifier)) #f)
(else (loop (rdc specifier))))))))
)

4
collects/srfi/63/63.ss
View File

@ -154,8 +154,8 @@
(and (s:equal? (vector-ref obj1 idx)
(vector-ref obj2 idx))
(lp (sub1 idx))))))
(and (my-array? obj1)
(my-array? obj2)
(and (array? obj1)
(array? obj2)
(equal? (array-dimensions obj1) (array-dimensions obj2))
(s:equal? (array->vector obj1) (array->vector obj2)))
(and (struct? obj1)