182 lines
8.6 KiB
Scheme
182 lines
8.6 KiB
Scheme
#!r6rs
|
|
(library (srfi srfi-29)
|
|
(export current-language current-country current-locale-details
|
|
declare-bundle! store-bundle store-bundle! load-bundle!
|
|
localized-template)
|
|
(import (rnrs) (srfi :6))
|
|
|
|
(define (current-locale-details . args)
|
|
(error 'current-locale-details
|
|
"procedure not supplied by reference implementation"))
|
|
|
|
(define-syntax store-bundle (identifier-syntax store-bundle!))
|
|
|
|
;; reference implementation taken from srfi :29 documenation
|
|
|
|
;; Copyright (C) Scott G. Miller (2002). All Rights Reserved.
|
|
;;
|
|
;; This document and translations of it may be copied and furnished to
|
|
;; others, and derivative works that comment on or otherwise explain it or
|
|
;; assist in its implementation may be prepared, copied, published and
|
|
;; distributed, in whole or in part, without restriction of any kind,
|
|
;; provided that the above copyright notice and this paragraph are included
|
|
;; on all such copies and derivative works. However, this document itself may
|
|
;; not be modified in any way, such as by removing the copyright notice or
|
|
;; references to the Scheme Request For Implementation process or editors,
|
|
;; except as needed for the purpose of developing SRFIs in which case the
|
|
;; procedures for copyrights defined in the SRFI process must be followed, or
|
|
;; as required to translate it into languages other than English.
|
|
;;
|
|
;; The limited permissions granted above are perpetual and will not be
|
|
;; revoked by the authors or their successors or assigns.
|
|
;;
|
|
;; This document and the information contained herein is provided on an "AS
|
|
;; IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES,
|
|
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE
|
|
;; OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
|
|
;;
|
|
|
|
;; The association list in which bundles will be stored
|
|
(define *localization-bundles* '())
|
|
|
|
;; The current-language and current-country functions provided
|
|
;; here must be rewritten for each Scheme system to default to the
|
|
;; actual locale of the session
|
|
(define current-language
|
|
(let ((current-language-value 'en))
|
|
(lambda args
|
|
(if (null? args)
|
|
current-language-value
|
|
(set! current-language-value (car args))))))
|
|
|
|
(define current-country
|
|
(let ((current-country-value 'us))
|
|
(lambda args
|
|
(if (null? args)
|
|
current-country-value
|
|
(set! current-country-value (car args))))))
|
|
|
|
;; The load-bundle! and store-bundle! both return #f in this
|
|
;; reference implementation. A compliant implementation need
|
|
;; not rewrite these procedures.
|
|
(define load-bundle!
|
|
(lambda (bundle-specifier)
|
|
#f))
|
|
|
|
(define store-bundle!
|
|
(lambda (bundle-specifier)
|
|
#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*))))))
|
|
|
|
;;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)))))))))))
|
|
|
|
;;An SRFI-28 and SRFI-29 compliant version of format. It requires
|
|
;;SRFI-23 for error reporting.
|
|
(define format
|
|
(lambda (format-string . objects)
|
|
(let ((buffer (open-output-string)))
|
|
(let loop ((format-list (string->list format-string))
|
|
(objects objects)
|
|
(object-override #f))
|
|
(cond ((null? format-list) (get-output-string buffer))
|
|
((char=? (car format-list) #\~)
|
|
(cond ((null? (cdr format-list))
|
|
(error 'format "Incomplete escape sequence"))
|
|
((char-numeric? (cadr format-list))
|
|
(let posloop ((fl (cddr format-list))
|
|
(pos (string->number
|
|
(string (cadr format-list)))))
|
|
(cond ((null? fl)
|
|
(error 'format "Incomplete escape sequence"))
|
|
((and (eq? (car fl) '#\@)
|
|
(null? (cdr fl)))
|
|
(error 'format "Incomplete escape sequence"))
|
|
((and (eq? (car fl) '#\@)
|
|
(eq? (cadr fl) '#\*))
|
|
(loop (cddr fl) objects (list-ref objects pos)))
|
|
(else
|
|
(posloop (cdr fl)
|
|
(+ (* 10 pos)
|
|
(string->number
|
|
(string (car fl)))))))))
|
|
(else
|
|
(case (cadr format-list)
|
|
((#\a)
|
|
(cond (object-override
|
|
(begin
|
|
(display object-override buffer)
|
|
(loop (cddr format-list) objects #f)))
|
|
((null? objects)
|
|
(error 'format "No value for escape sequence"))
|
|
(else
|
|
(begin
|
|
(display (car objects) buffer)
|
|
(loop (cddr format-list)
|
|
(cdr objects) #f)))))
|
|
((#\s)
|
|
(cond (object-override
|
|
(begin
|
|
(display object-override buffer)
|
|
(loop (cddr format-list) objects #f)))
|
|
((null? objects)
|
|
(error 'format "No value for escape sequence"))
|
|
(else
|
|
(begin
|
|
(write (car objects) buffer)
|
|
(loop (cddr format-list)
|
|
(cdr objects) #f)))))
|
|
((#\%)
|
|
(if object-override
|
|
(error 'format "Escape sequence following positional override does not require a value"))
|
|
(display #\linefeed buffer)
|
|
(loop (cddr format-list) objects #f))
|
|
((#\~)
|
|
(if object-override
|
|
(error 'format "Escape sequence following positional override does not require a value"))
|
|
(display #\~ buffer)
|
|
(loop (cddr format-list) objects #f))
|
|
(else
|
|
(error 'format "Unrecognized escape sequence"))))))
|
|
(else (display (car format-list) buffer)
|
|
(loop (cdr format-list) objects #f)))))))
|
|
)
|