Update of /project/cl-l10n/cvsroot/cl-l10n
In directory clnet:/tmp/cvs-serv6511
Modified Files:
cl-l10n.asd i18n.lisp load-locale.lisp locale.lisp
package.lisp parse-time.lisp parsers.lisp printers.lisp
Log Message:
Merge attila.lendvai(a)gmail.com's changes, mostly i18n stuff
--- /project/cl-l10n/cvsroot/cl-l10n/cl-l10n.asd 2006/04/27 18:30:30 1.15
+++ /project/cl-l10n/cvsroot/cl-l10n/cl-l10n.asd 2006/06/08 09:38:19 1.16
@@ -28,7 +28,6 @@
(defmethod perform :after ((o load-op) (c (eql (find-system :cl-l10n))))
(provide 'cl-l10n))
-
(defmethod perform ((op test-op) (sys (eql (find-system :cl-l10n))))
(oos 'load-op :cl-l10n-tests)
--- /project/cl-l10n/cvsroot/cl-l10n/i18n.lisp 2006/04/27 18:30:30 1.4
+++ /project/cl-l10n/cvsroot/cl-l10n/i18n.lisp 2006/06/08 09:38:19 1.5
@@ -2,68 +2,120 @@
;; See the file LICENCE for licence information.
(in-package :cl-l10n)
+#|
+(defresources en
+ (indefinit-article-for (str)
+ ;; calculate "a"/"an" here
+ )
+ (foo.bar "some constant"))
+
+then writing (indefinit-article-for "asdf") will call the locale-specific
+implementation of that function
+
+|#
+
+(defvar *resources* (make-hash-table :test 'equal))
+
+(defun clear-resources ()
+ (setf *resources* (make-hash-table :test 'equal)))
+
+(defun resource-key (locale name)
+ (list (if (stringp locale) locale (locale-name locale))
+ (if (stringp name) (string-downcase name) (string-downcase (symbol-name name)))))
+
+(define-condition resource-missing (warning)
+ ((name :accessor name-of :initarg :name)))
+
+(defun add-resource (locale name args body)
+ ;; store in resouce map
+ (setf (gethash (resource-key locale name) *resources*)
+ (if (and (= (length body) 1)
+ (stringp (first body)))
+ (first body)
+ (eval `(lambda ,args ,@body))))
+ ;; make a function
+ (setf (symbol-function name) (eval `(lambda (&rest args) (lookup-resource ',name args))))
+ name)
+
+(defun %lookup-resource (locale name args)
+ (declare (type locale locale)
+ (type (or symbol string) name))
+ (let* ((key (resource-key locale name)))
+ (multiple-value-bind (resource found)
+ (gethash key *resources*)
+ (unless found
+ ;; try again with the default locale for the language
+ (setf key (resource-key (canonical-locale-name-from (first (split "_" (locale-name locale)))) name))
+ (setf resource (gethash key *resources*)))
+ ;; dispatch on resource type
+ (cond ((functionp resource)
+ (apply resource args))
+ ;; literal
+ ((not (null resource))
+ resource)))))
+
+(defun lookup-resource (name args &key (warn-if-missing t) (fallback-to-name t))
+ (loop for locale in (if (consp *locale*) *locale* (list *locale*)) do
+ (let ((result (funcall '%lookup-resource locale name args)))
+ (when result
+ (return-from lookup-resource (values result t)))))
+ (resource-not-found name warn-if-missing fallback-to-name))
+
+(defun lookup-resource-without-fallback (locale name args &key (warn-if-missing t) (fallback-to-name t))
+ (aif (%lookup-resource locale name args)
+ it
+ (resource-not-found name warn-if-missing fallback-to-name)))
+
+(defun resource-not-found (name warn-if-missing fallback-to-name)
+ (if warn-if-missing
+ (signal 'resource-missing :name name))
+ (values (if fallback-to-name
+ (string-downcase (string name)))
+ nil))
+
+(defmacro defresources (locale &body resources)
+ (let ((locale-name (canonical-locale-name-from locale)))
+ (cons 'progn
+ (loop for resource in resources
+ if (= 2 (length resource))
+ collect `(add-resource ,locale-name
+ ',(first resource) nil ',(cdr resource))
+ else
+ collect `(add-resource ,locale-name
+ ',(first resource) ',(second resource) ',(cddr resource))))))
+
+(defmacro enable-sharpquote-reader ()
+ "Enable quote reader for the rest of the file (being loaded or compiled).
+#\"my i18n text\" parts will be replaced by a lookup-resource call for the string.
+Be careful when using in different situations, because it modifies *readtable*."
+ ;; The standard sais that *readtable* is restored after loading/compiling a file,
+ ;; so we make a copy and alter that. The effect is that it will be enabled
+ ;; for the rest of the file being processed.
+ `(eval-when (:compile-toplevel :execute)
+ (setf *readtable* (copy-readtable *readtable*))
+ (%enable-sharpquote-reader)))
+
+(defun %enable-sharpquote-reader ()
+ (set-dispatch-macro-character
+ #\# #\"
+ #'(lambda (s c1 c2)
+ (declare (ignore c2))
+ (unread-char c1 s)
+ `(lookup-resource ,(read s) nil))))
+
+(defun with-sharpquote-syntax ()
+ "To be used with the curly reader from arnesi: {with-sharpquote-reader (foo #\"locale-specific\") }"
+ (lambda (handler)
+ (%enable-sharpquote-reader)
+ `(progn ,@(funcall handler))))
-;; (defparameter bundle (make-instance 'bundle))
-;; (add-resources (bundle "af_")
-;; "showtime" "Dankie, die tyd is ~:@U~%")
-;; ;; an empty string as the locale matcher becomes the default
-;; (add-resources (bundle "")
-;; "showtime" "Thanks, the time is ~:@U~%")
-
-;; (set-dispatch-macro-character
-;; #\# #\i
-;; #'(lambda (s c1 c2)
-;; (declare (ignore c2))
-;; `(cl-l10n:gettext ,(read s) bundle)))
-
-;; or this
-;; (defmacro _ (text)
-;; `(cl-l10n:gettext ,text bundle))
-
-;; (defun timey ()
-;; (format t #i"showtime" (get-universal-time)))
-
-(defclass bundle ()
- ((resources :accessor resources :initform (make-hash-table :test #'equal))))
-
-(defgeneric add-resource (bundle from to lang))
-(defmethod add-resource (bundle from to lang)
- (aif (assoc lang (gethash from (resources bundle)) :test #'equal)
- (setf (cdr it) to)
- (pushnew (cons lang to) (gethash from (resources bundle))
- :test #'equal))
- t)
-
-(defmacro add-resources ((bundle loc-name) &body args)
- (with-gensyms (gloc gbundle)
- `(let ((,gloc ,loc-name) (,gbundle ,bundle))
- ,@(mapcar #'(lambda (x) `(add-resource ,gbundle ,@x ,gloc))
- (group args 2)))))
-
-(defgeneric get-name (bundle name)
- (:method ((bundle t) (name t))
- (gethash name (resources bundle))))
-
-(defgeneric lookup-name (bundle name)
- (:method ((bundle t) (name t))
- (when-let (name (get-name bundle name))
- ;; The match with the longest name is the most
- ;; specific key.
- (winner #'>
- (load-time-value (compose #'length #'car))
- (remove-if-not #'(lambda (x)
- (search (car x)
- (locale-name *locale*)))
- name)))))
-
-(defun gettext (name bundle &optional (loc *locale*))
- (let ((*locale* (locale-des->locale loc)))
- (or (cdr (lookup-name bundle name))
- name)))
+(defgeneric localize (object)
+ (:documentation "Override this generic method for various data types. Return (values result foundp)."))
+(defmethod localize ((str string))
+ (lookup-resource str nil))
-
-
-;; EOF
+(defmethod localize ((str symbol))
+ (lookup-resource str nil))
--- /project/cl-l10n/cvsroot/cl-l10n/load-locale.lisp 2006/06/06 14:58:46 1.16
+++ /project/cl-l10n/cvsroot/cl-l10n/load-locale.lisp 2006/06/08 09:38:19 1.17
@@ -5,23 +5,69 @@
(defparameter *ignore-categories*
(list "LC_CTYPE" "LC_COLLATE"))
+(defparameter *language->default-locale-name* (make-hash-table :test #'equal)
+ "This map specifies what is the default locale for locale specifications without a region (i.e. en_US for en)")
+
+(deftype locale-descriptor ()
+ `(or locale string symbol))
+
+(defun canonical-locale-name-from (locale)
+ (check-type locale locale-descriptor)
+ (if (typep locale 'locale)
+ (locale-name locale)
+ (let ((name locale))
+ (when (and (not (null name))
+ (symbolp name))
+ (setf name (symbol-name name)))
+ (let* ((parts (split "_" name))
+ (count (list-length parts))
+ (first-length (length (first parts)))
+ (second-length (length (second parts))))
+ (when (> count 2)
+ (error "Locale variants are not yet supported"))
+ (when (or (> first-length 3)
+ (< first-length 2)
+ (and (> count 1)
+ (or (> second-length 3)
+ (< second-length 2))))
+ (error "~A is not a valid locale name (examples: en_GB, en_US, en)" locale))
+ (let ((language (string-downcase (first parts)))
+ (region (when (> count 1)
+ (second parts))))
+ (if (> count 1)
+ (concatenate 'string language "_" region)
+ (aif (gethash language *language->default-locale-name*)
+ it
+ (concatenate 'string language "_" (string-upcase language)))))))))
+
+;; set up the default region mappings while loading
+(eval-when (:load-toplevel :execute)
+ (loop for (language locale) in
+ '((en "en_US")) do
+ (setf (gethash (string-downcase (symbol-name language)) *language->default-locale-name*)
+ (canonical-locale-name-from locale)))
+ (values))
+
;; Add a restart here?
(defun locale (loc-name &key (use-cache t) (errorp t) (loader nil))
- "Find locale named by the string LOC-NAME. If USE-CACHE
+ "Find locale named by the specification LOC-NAME. If USE-CACHE
is non-nil forcefully reload the locale from *locale-path* else
the locale is first looked for in *locales*. If ERRORP is non-nil
signal a warning rather than an error if the locale file cannot be found.
If LOADER is non-nil skip everything and call loader with LOC-NAME."
- (let ((name (aif (position #\. loc-name)
- (subseq loc-name 0 it)
- loc-name)))
- (acond ((and (not name) (not errorp)) nil)
- ((and use-cache (get-locale name)) it)
- (loader (setf (get-locale name) (funcall loader name)))
- ((probe-file (merge-pathnames *locale-path* name))
- (setf (get-locale name) (load-locale name)))
- (t (funcall (if errorp #'error #'warn)
- "Can't find locale ~A." name)))))
+ (if (typep loc-name 'locale)
+ loc-name
+ (let ((name (canonical-locale-name-from
+ (aif (position #\. loc-name)
+ (subseq loc-name 0 it)
+ loc-name))))
+ (acond ((and (not name) (not errorp)) nil)
+ ((and use-cache (get-locale name)) it)
+ (loader (setf (get-locale name) (funcall loader name)))
+ ((probe-file (merge-pathnames *locale-path* name))
+ (setf (get-locale name) (load-locale name)))
+ (t (funcall (if errorp #'error #'warn)
+ "Can't find locale ~A." name))))))
(defvar *locale-type* 'locale
"The class of loaded locales.")
@@ -29,18 +75,6 @@
(defvar *category-type* 'category
"The class of loaded categories")
-(deftype locale-descriptor ()
- `(or locale string symbol))
-
-(defun locale-des->locale (loc)
- "Turns a locale descriptor(a string, symbol or locale) into an
-actual locale object."
- (check-type loc locale-descriptor)
- (etypecase loc
- (locale loc)
- (string (locale loc))
- (symbol (locale (string loc)))))
-
(defun load-locale (name)
(let ((path (merge-pathnames *locale-path* name))
(ef #+sbcl :iso-8859-1
@@ -360,16 +394,26 @@
(return-from next-header (trim line)))))
(defun set-locale (locale-des)
- (setf *locale* (locale-des->locale locale-des)))
+ (setf *locale* (if (listp locale-des)
+ (loop for locale in locale-des
+ collect (locale locale))
+ (locale locale-des))))
+
+(defmacro with-locale (locale &body body)
+ `(let ((*locale* (locale ,locale)))
+ ,@body))
(defun load-default-locale ()
- (setf *locale* (get-default-locale)))
+ (set-locale (get-default-locale)))
(defun get-default-locale ()
- (or (locale (getenv "CL_LOCALE") :errorp nil)
- (locale (getenv "LC_CTYPE") :errorp nil)
- (locale (getenv "LANG") :errorp nil)
- (locale "POSIX" :errorp nil)))
+ (macrolet ((try (name)
+ `(when-let (it (getenv ,name))
+ (locale it :errorp nil))))
+ (or (try "CL_LOCALE")
+ (try "LC_CTYPE")
+ (try "LANG")
+ (locale "POSIX" :errorp nil))))
(eval-when (:load-toplevel :execute)
(load-default-locale))
--- /project/cl-l10n/cvsroot/cl-l10n/locale.lisp 2006/04/27 18:30:30 1.12
+++ /project/cl-l10n/cvsroot/cl-l10n/locale.lisp 2006/06/08 09:38:19 1.13
@@ -16,7 +16,14 @@
(merge-pathnames (make-pathname :directory '(:relative "locales"))
(asdf:component-pathname (asdf:find-system :cl-l10n))))
-(defvar *locale* nil)
+(defvar *locale* nil
+ "Either a locale or a list of locales in which case resources will be looked for in each locale in order.")
+
+(defun current-locale ()
+ (declare (inline current-locale))
+ (if (consp *locale*)
+ (car *locale*)
+ *locale*))
(defvar *locales* (make-hash-table :test #'equal)
"Hash table containing all loaded locales keyed on name (eg. \"af_ZA\")")
@@ -101,8 +108,8 @@
(defmacro defgetter (key cat &key (wrap '#'identity))
(let ((name (symb "LOCALE-" (substitute #\- #\_ (string-upcase key)))))
`(progn
- (defun ,name (&optional (locale *locale*))
- (let ((locale (locale-des->locale locale)))
+ (defun ,name (&optional (locale (current-locale)))
+ (let ((locale (locale locale)))
(when locale
(funcall ,wrap (locale-value locale ,cat ,key)))))
(export ',name))))
--- /project/cl-l10n/cvsroot/cl-l10n/package.lisp 2006/04/27 18:30:30 1.8
+++ /project/cl-l10n/cvsroot/cl-l10n/package.lisp 2006/06/08 09:38:19 1.9
@@ -7,12 +7,16 @@
(:shadow cl:format cl:formatter)
(:export #:locale-name #:category-name #:locale #:category #:locale-error
#:get-category #:get-cat-val #:locale-value #:load-all-locales
- #:*locale* #:*locale-path* #:*locales* #:load-default-locale
+ #:get-locale #:*locale-path* #:*locales* #:load-default-locale
#:format-number #:print-number #:format-money #:print-money
- #:format-time #:print-time #:add-resources #:bundle
- #:add-resource #:gettext #:parse-number #:*float-digits*
+ #:format-time #:print-time #:add-resources
+ #:parse-number #:*float-digits*
#:parse-time #:month #:day #:year #:hour #:minute #:second
#:date-divider #:time-divider #:weekday #:noon-midn #:shadow-format
- #:secondp #:am-pm #:zone #:parser-error #:set-locale))
+ #:secondp #:am-pm #:zone #:parser-error #:set-locale
+ #:with-locale #:lookup-resource
+ #:lookup-resource-without-fallback #:localize
+ #:missing-resource #:defresources #:enable-sharpquote-reader
+ #:with-sharpquote-reader))
--- /project/cl-l10n/cvsroot/cl-l10n/parse-time.lisp 2006/04/27 18:30:30 1.3
+++ /project/cl-l10n/cvsroot/cl-l10n/parse-time.lisp 2006/06/08 09:38:19 1.4
@@ -600,7 +600,7 @@
;; patterns have not been explicitly specified so we try
;; to match against locale a specific date pattern first.
;; eg. 03/04/2005 is 3rd April in UK but 4 March in US.
- (dolist (pattern (parsers *locale*))
+ (dolist (pattern (parsers (current-locale)))
(let ((res (match-pattern pattern
string-parts
parts-length)))
@@ -620,7 +620,7 @@
(default-hours nil) (default-day nil)
(default-month nil) (default-year nil)
(default-zone nil) (default-weekday nil)
- (locale *locale*))
+ (locale (current-locale)))
"Tries very hard to make sense out of the argument time-string using
locale and returns a single integer representing the universal time if
successful. If not, it returns nil. If the :error-on-mismatch
@@ -630,21 +630,21 @@
keywords can be given a numeric value or the keyword :current
to set them to the current value. The default-default values
are 00:00:00 on the current date, current time-zone."
- (let* ((*error-on-mismatch* error-on-mismatch)
- (*locale* (locale-des->locale locale))
- (string-parts (decompose-string time-string :start start :end end))
- (parts-length (length string-parts))
- (string-form (get-matching-pattern patterns string-parts parts-length)))
- (if string-form
- (let ((parsed-values (make-default-time default-seconds default-minutes
- default-hours default-day
- default-month default-year
- default-zone default-weekday)))
- (set-time-values string-form parsed-values)
- (convert-to-unitime parsed-values))
- (if *error-on-mismatch*
- (error 'parser-error :value time-string :reason "Not a recognized time/date format.")
- nil))))
+ (with-locale locale
+ (let* ((*error-on-mismatch* error-on-mismatch)
+ (string-parts (decompose-string time-string :start start :end end))
+ (parts-length (length string-parts))
+ (string-form (get-matching-pattern patterns string-parts parts-length)))
+ (if string-form
+ (let ((parsed-values (make-default-time default-seconds default-minutes
+ default-hours default-day
+ default-month default-year
+ default-zone default-weekday)))
+ (set-time-values string-form parsed-values)
+ (convert-to-unitime parsed-values))
+ (if *error-on-mismatch*
+ (error 'parser-error :value time-string :reason "Not a recognized time/date format.")
+ nil)))))
; EOF
--- /project/cl-l10n/cvsroot/cl-l10n/parsers.lisp 2005/05/18 15:34:08 1.4
+++ /project/cl-l10n/cvsroot/cl-l10n/parsers.lisp 2006/06/08 09:38:20 1.5
@@ -1,7 +1,7 @@
(in-package :cl-l10n)
-(defun parse-number (num &optional (locale *locale*))
- (let ((locale (locale-des->locale locale)))
+(defun parse-number (num &optional (locale (current-locale)))
+ (let ((locale (locale locale)))
(%parse-number (replace-dp (remove-ts num locale) locale))))
(defun remove-ts (num locale)
--- /project/cl-l10n/cvsroot/cl-l10n/printers.lisp 2006/04/27 18:30:30 1.17
+++ /project/cl-l10n/cvsroot/cl-l10n/printers.lisp 2006/06/08 09:38:20 1.18
@@ -21,8 +21,8 @@
(princ "0" s)))))
(defun format-number (stream arg no-dp no-ts
- &optional (locale *locale*))
- (let ((locale (locale-des->locale locale))
+ &optional (locale (current-locale)))
+ (let ((locale (locale locale))
(float-part (float-part (coerce (abs arg) 'double-float))))
(cl:format stream
(getf (printers locale)
@@ -35,7 +35,7 @@
(values)))
(defun print-number (number &key (stream *standard-output*)
- no-ts no-dp (locale *locale*))
+ no-ts no-dp (locale (current-locale)))
(format-number stream number no-dp no-ts locale)
number)
@@ -60,8 +60,8 @@
:money-p-no-ts
:money-p-ts)))
-(defun format-money (stream arg use-int-sym no-ts &optional (locale *locale*))
- (let* ((locale (locale-des->locale locale))
+(defun format-money (stream arg use-int-sym no-ts &optional (locale (current-locale)))
+ (let* ((locale (locale locale))
(frac-digits (max (if use-int-sym
(locale-int-frac-digits locale)
(locale-frac-digits locale))
@@ -85,7 +85,7 @@
(values))
(defun print-money (num &key (stream *standard-output*) use-int-sym no-ts
- (locale *locale*))
+ (locale (current-locale)))
(format-money stream num use-int-sym no-ts locale)
num)
@@ -119,15 +119,16 @@
(defun princ-pad-val (val stream &optional (pad "0") (size 2))
(declare (type stream stream) (optimize speed)
- (type fixnum val))
+ (type fixnum val size))
(assert (not (minusp val)) (val) "Value ~A cannot be smaller than 0." val)
(cond ((zerop val)
(dotimes (x (1- size))
(princ pad stream))
(princ 0 stream))
(t
- (loop for x = (* val 10) then (* x 10)
- until (>= x (expt 10 size)) do
+ (loop with stop-value = (expt 10 size)
+ for x integer = (* val 10) then (* x 10)
+ until (>= x stop-value) do
(princ pad stream))
(princ val stream))))
@@ -316,8 +317,8 @@
(defvar *time-zone*)
-(defun format-time (stream ut show-date show-time &optional (locale *locale*) fmt time-zone)
- (let ((locale (locale-des->locale (or locale *locale*)))
+(defun format-time (stream ut show-date show-time &optional (locale (current-locale)) fmt time-zone)
+ (let ((locale (locale locale))
(*time-zone* (or time-zone (nth-value 8 (decode-universal-time ut)))))
(print-time-string (or fmt (get-time-fmt-string locale
show-date show-time))
@@ -348,7 +349,7 @@
(princ x stream)))))))
(defun print-time (ut &key show-date show-time (stream *standard-output*)
- (locale *locale*) fmt time-zone)
+ (locale (current-locale)) fmt time-zone)
(format-time stream ut show-date show-time locale fmt time-zone)
ut)
@@ -386,7 +387,7 @@
string))
(defun really-parse-fmt-string (string)
- (declare (optimize speed) (type string string))
+ (declare (optimize speed) (type simple-string string))
(with-output-to-string (fmt-string)
(loop for char across string
with tilde = nil do
