excessive cleanups after cldr 1.8.0 update
Tue Apr 6 14:08:50 PDT 2010 attila.lendvai@gmail.com
* excessive cleanups after cldr 1.8.0 update
diff -rN -u old-cl-l10n/src/calendar.lisp new-cl-l10n/src/calendar.lisp
--- old-cl-l10n/src/calendar.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/calendar.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -80,22 +80,24 @@
(awhen (funcall name-vector-slot-reader it)
(setf result it)
(return))))
- (when (some #'null result)
- ;; if it's partial then make a copy and fill it in
- (setf result (copy-seq result))
- (iter (for index :from 0 :below (length result))
- (unless (aref result index)
- (bind ((inherited-name (do-current-locales locale
- (awhen (funcall calendar-slot-reader locale)
- (awhen (funcall name-vector-slot-reader it)
- (awhen (aref it index)
- (return it)))))))
- (unless inherited-name
- (cldr-parser-warning "Locale ~A has no value at index ~A of gregorian date part name ~A"
- (current-locale) index name-vector-slot-reader)
- (when defaults
- (setf inherited-name (aref defaults index))))
- (setf (aref result index) inherited-name)))))
+ (if result
+ (when (some #'null result)
+ ;; if it's partial then make a copy and fill it in
+ (setf result (copy-seq result))
+ (iter (for index :from 0 :below (length result))
+ (unless (aref result index)
+ (bind ((inherited-name (do-current-locales locale
+ (awhen (funcall calendar-slot-reader locale)
+ (awhen (funcall name-vector-slot-reader it)
+ (awhen (aref it index)
+ (return it)))))))
+ (unless inherited-name
+ (cldr-parser-warning "Locale ~A has no value at index ~A of gregorian date part name ~A"
+ (current-locale) index name-vector-slot-reader)
+ (when defaults
+ (setf inherited-name (aref defaults index))))
+ (setf (aref result index) inherited-name)))))
+ (setf result defaults))
result))
(defun effective-date-related-names/gregorian-calendar (name-vector-slot-reader &optional defaults)
diff -rN -u old-cl-l10n/src/cldr-parsing.lisp new-cl-l10n/src/cldr-parsing.lisp
--- old-cl-l10n/src/cldr-parsing.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/cldr-parsing.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -90,30 +90,25 @@
(defun compile-time-formatters/gregorian-calendar (locale)
(compile-date-or-time-formatters/gregorian-calendar locale 'time-formatters-of))
-(defun compile-simple-number-formatters (locale formatters-accessor pattern-compiler)
- (bind ((formatters (funcall formatters-accessor locale)))
- (iter (for verbosity in formatters by #'cddr)
- (with pattern = (getf (getf formatters verbosity) :pattern))
- (setf (getf formatters verbosity)
- (list :formatter (funcall pattern-compiler pattern)
- :pattern pattern)))))
+(defmacro compile-simple-number-formatters (formatters-accessor-form pattern-compiler)
+ `(iter (for verbosity :in (mapcar #'car ,formatters-accessor-form) by #'cddr)
+ (for entry = (assoc-value ,formatters-accessor-form verbosity))
+ (setf (getf entry :formatter) (funcall ,pattern-compiler (getf entry :pattern)))
+ (setf (assoc-value ,formatters-accessor-form verbosity) entry)))
(defun compile-number-formatters/decimal (locale)
- (compile-simple-number-formatters locale #'decimal-formatters-of #'compile-number-pattern/decimal))
+ (compile-simple-number-formatters (decimal-formatters-of locale) #'compile-number-pattern/decimal))
(defun compile-number-formatters/percent (locale)
- (compile-simple-number-formatters locale #'percent-formatters-of #'compile-number-pattern/percent))
+ (compile-simple-number-formatters (percent-formatters-of locale) #'compile-number-pattern/percent))
(defun compile-number-formatters/currency (locale)
(bind ((currency-formatter (currency-formatter-of locale)))
(when currency-formatter
- (setf (pattern-verbosity-list-of currency-formatter)
- (iter (for (verbosity entry) :on (pattern-verbosity-list-of currency-formatter) :by #'cddr)
- (for pattern = (getf entry :pattern))
- (assert pattern)
- (setf (getf entry :formatter) (compile-number-pattern/currency pattern))
- (collect verbosity)
- (collect entry))))))
+ (iter (for verbosity :in (mapcar #'car (formatters-of currency-formatter)))
+ (for entry = (assoc-value (formatters-of currency-formatter) verbosity))
+ (setf (getf entry :formatter) (compile-number-pattern/currency (getf entry :pattern)))
+ (setf (assoc-value (formatters-of currency-formatter) verbosity) entry)))))
(defun dummy-formatter (&rest args)
(declare (ignore args))
@@ -263,17 +258,15 @@
(push (cons name value) (number-symbols-of *locale*))))
(:method ((parent ldml:currencies) (node ldml:currency))
- (bind ((name (slot-value node 'ldml::type)))
- (assert (every #'upper-case-p name))
- (setf name (ldml-intern name))
+ (bind ((currency-code (slot-value node 'ldml::type)))
+ (assert (every #'upper-case-p currency-code))
+ (setf currency-code (ldml-intern currency-code))
+ (when-bind symbol-node (flexml:first-child-with-local-name node "symbol")
+ (bind ((symbol (flexml:string-content-of symbol-node)))
+ (setf (symbol-of (ensure-currency *locale* currency-code)) symbol)))
(when-bind display-name-node (flexml:first-child-with-local-name node "displayName")
- (bind ((display-name (flexml:string-content-of display-name-node))
- (symbol (awhen (flexml:first-child-with-local-name node "symbol")
- (flexml:string-content-of it)))
- (entry (list* display-name
- (when symbol
- (list symbol)))))
- (setf (gethash name (currencies-of *locale*)) entry)))))
+ (bind ((long-name (flexml:string-content-of display-name-node)))
+ (setf (long-name-of (ensure-currency *locale* currency-code)) long-name)))))
(:method ((parent ldml:numbers) (node ldml:currency-formats))
(setf (currency-formatter-of *locale*) (make-instance 'currency-formatter))
@@ -293,8 +286,8 @@
(unless (length= 1 (flexml:children-of inbetween-node))
(cldr-parser-warning "LDML node ~A has multiple children, using the first one" inbetween-node))
(bind ((pattern (flexml:string-content-of (flexml:first-child inbetween-node))))
- (setf (getf (pattern-verbosity-list-of (currency-formatter-of *locale*)) name)
- (list :formatter 'dummy-formatter :pattern pattern)))))
+ (setf (assoc-value (formatters-of (currency-formatter-of *locale*)) name)
+ (list :pattern pattern)))))
(:method ((parent ldml:currency-formats) (node ldml:unit-pattern))
(bind ((ldml-count (slot-value node 'ldml::count))
@@ -321,23 +314,21 @@
(process-ldml-gregorian-calendar-node parent node))
(call-next-method)))
(:method ((parent ldml:decimal-formats) (node ldml:decimal-format-length))
- (process-simple-number-formatter-node node 'decimal-formatters-of))
-
+ (push (process-simple-number-formatter-node node)
+ (decimal-formatters-of *locale*)))
+
(:method ((parent ldml:percent-formats) (node ldml:percent-format-length))
- (process-simple-number-formatter-node node 'percent-formatters-of))
- )
+ (push (process-simple-number-formatter-node node)
+ (percent-formatters-of *locale*))))
-(defun process-simple-number-formatter-node (node formatter-accessor)
+(defun process-simple-number-formatter-node (node)
(bind ((ldml-type (slot-value node 'ldml::type))
- (name (and ldml-type (ldml-intern ldml-type)))
- (inbetween-node (flexml:the-only-child node)))
+ (name (and ldml-type (ldml-intern ldml-type)))
+ (inbetween-node (flexml:the-only-child node)))
(unless (length= 1 (flexml:children-of inbetween-node))
(cldr-parser-warning "LDML node ~A has multiple children, using the first one" inbetween-node))
- (bind ((pattern (flexml:string-content-of (flexml:first-child inbetween-node)))
- (formatter (funcall formatter-accessor *locale*)))
- (setf (getf formatter name)
- (list :formatter 'dummy-formatter :pattern pattern))
- (funcall (fdefinition `(setf ,formatter-accessor)) formatter *locale*))))
+ (bind ((pattern (flexml:string-content-of (flexml:first-child inbetween-node))))
+ (list name :pattern pattern))))
(defun process-langauge-list-like-ldml-node (node accessor)
(let* ((name (string-upcase (slot-value node 'ldml::type))))
diff -rN -u old-cl-l10n/src/formatters.lisp new-cl-l10n/src/formatters.lisp
--- old-cl-l10n/src/formatters.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/formatters.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -11,18 +11,23 @@
(:full 'ldml:full)))
(defmacro with-normalized-stream-variable (stream &body body)
- (with-unique-names (to-string?)
- `(bind ((,to-string? nil))
- (cond
- ((null ,stream)
- (setf ,stream (make-string-output-stream))
- (setf ,to-string? t))
- ((eq ,stream t)
- (setf ,stream *standard-output*)))
- ,@body
- (if ,to-string?
- (get-output-stream-string ,stream)
- ,stream))))
+ (check-type stream (and symbol (not (member nil t))))
+ (with-unique-names (body-fn to-string?)
+ `(flet ((,body-fn ()
+ ,@body))
+ (if (streamp ,stream)
+ (,body-fn)
+ (bind ((,to-string? nil))
+ (cond
+ ((null ,stream)
+ (setf ,stream (make-string-output-stream))
+ (setf ,to-string? t))
+ ((eq ,stream t)
+ (setf ,stream *standard-output*)))
+ (,body-fn)
+ (if ,to-string?
+ (get-output-stream-string ,stream)
+ ,stream))))))
(defun %format-iterating-locales (stream locale-visitor fallback-fn)
(declare (optimize speed)
@@ -65,33 +70,32 @@
(defun %format-date-or-time/gregorian-calendar (stream value warning-string formatter-slot-reader fallback-pattern &key (verbosity 'ldml:medium) pattern )
(check-type pattern (or null string function))
(setf verbosity (or (keyword-to-ldml verbosity) verbosity))
- (%format-iterating-locales
- stream
- (if pattern
- (named-lambda %format-date-or-time/gregorian-calendar/visitor (stream locale)
- (declare (ignore locale))
- (funcall (etypecase pattern
- (string
- ;; NOTE: this code path is about 5 times slower and conses about 10 times more...
- ;; OPTIMIZATION: we could implement some per-locale caching here, but it must be
- ;; carefully keyed (a compiled lambda captures stuff at compile time from the compile time value of *locale*)
- ;; and the cache must be properly locked to support threading.
- (compile-date-time-pattern/gregorian-calendar pattern))
- (function pattern))
- stream value)
- t)
- (named-lambda %format-date-or-time/gregorian-calendar/visitor (stream locale)
- (when-bind gregorian-calendar (gregorian-calendar-of locale)
- (bind ((formatter-entry (getf (funcall formatter-slot-reader gregorian-calendar) verbosity))
- (formatter (getf formatter-entry :formatter)))
- (if formatter
- (progn
- (funcall formatter stream value)
- t)
- nil)))))
- (named-lambda %format-date-or-time/gregorian-calendar/fallback (stream)
- (warn warning-string verbosity (current-locale))
- (local-time:format-timestring stream value :format fallback-pattern))))
+ (etypecase pattern
+ (string
+ ;; NOTE: this code path is about 5 times slower and conses about 10 times more...
+ ;; OPTIMIZATION: we could implement some per-locale caching here, but it must be
+ ;; carefully keyed (a compiled lambda captures stuff at compile time from the compile time value of *locale*)
+ ;; and the cache must be properly locked to support threading.
+ (with-normalized-stream-variable stream
+ (funcall (compile-date-time-pattern/gregorian-calendar pattern) stream value)))
+ (compiled-pattern
+ (with-normalized-stream-variable stream
+ (funcall pattern stream value)))
+ (null
+ (%format-iterating-locales
+ stream
+ (named-lambda %format-date-or-time/gregorian-calendar/visitor (stream locale)
+ (when-bind gregorian-calendar (gregorian-calendar-of locale)
+ (bind ((formatter-entry (getf (funcall formatter-slot-reader gregorian-calendar) verbosity))
+ (formatter (getf formatter-entry :formatter)))
+ (if formatter
+ (progn
+ (funcall formatter stream value)
+ t)
+ nil))))
+ (named-lambda %format-date-or-time/gregorian-calendar/fallback (stream)
+ (warn warning-string verbosity (current-locale))
+ (local-time:format-timestring stream value :format fallback-pattern))))))
(defun format-date/gregorian-calendar (stream date &key (verbosity 'ldml:medium) pattern)
(%format-date-or-time/gregorian-calendar stream date "No Gregorian calendar date formatter was found with verbosity ~S for locale ~A. Ignoring the locale and printing in a fixed simple format."
@@ -111,66 +115,58 @@
(defun format-number/currency (stream number currency-code &key (verbosity 'ldml:medium) pattern)
(setf verbosity (or (keyword-to-ldml verbosity) verbosity))
- (%format-iterating-locales
- stream
- (if pattern
- (named-lambda format-number/currency/visitor (stream locale)
- (declare (ignore locale))
- (funcall (etypecase pattern
- (string
- ;; NOTE: this code path is A LOT slower. see similar notes around this file for more details.
- (compile-number-pattern/currency pattern))
- (function pattern))
- stream number currency-code)
- t)
- (named-lambda format-number/currency/visitor (stream locale)
- (awhen (currency-formatter-of locale)
- (awhen (pattern-verbosity-list-of it)
- (awhen (or (getf it verbosity)
- (getf it nil))
- (bind ((formatter (getf it :formatter)))
- (if formatter
- (progn
- (funcall formatter stream number currency-code)
- t)
- nil)))))))
- (named-lambda format-number/currency/fallback (stream)
- (warn "No currency formatter was found with verbosity ~S for locale ~A. Ignoring the locale and printing in a fixed simple format."
- verbosity (current-locale))
- (cl:format stream "~A ~A" number currency-code))))
+ (etypecase pattern
+ (compiled-pattern
+ (with-normalized-stream-variable stream
+ (funcall pattern stream number currency-code)))
+ (string
+ (with-normalized-stream-variable stream
+ (funcall (compile-number-pattern/currency pattern) stream number currency-code)))
+ (null
+ (%format-iterating-locales
+ stream
+ (named-lambda format-number/currency/visitor (stream locale)
+ (awhen (currency-formatter-of locale)
+ (bind ((entry (or (assoc-value (formatters-of it) verbosity)
+ (assoc-value (formatters-of it) nil)))
+ (formatter (getf entry :formatter)))
+ (if formatter
+ (progn
+ (funcall formatter stream number currency-code)
+ t)
+ nil))))
+ (named-lambda format-number/currency/fallback (stream)
+ (warn "No currency formatter was found with verbosity ~S for locale ~A. Ignoring the locale and printing in a fixed simple format."
+ verbosity (current-locale))
+ (cl:format stream "~A ~A" number currency-code))))))
(defun %format-number (stream number verbosity
pattern pattern-compiler
formatter-accessor formatter-name fallback-format-pattern)
(setf verbosity (or (keyword-to-ldml verbosity) verbosity))
- (%format-iterating-locales
- stream
- (if pattern
- (named-lambda %format-number/visitor (stream locale)
- (declare (ignore locale))
- (funcall (etypecase pattern
- (string
- ;; NOTE: this code path is about 10 times slower and conses about 10 times more...
- ;; OPTIMIZATION: we could implement some per-locale caching here, but it must be
- ;; carefully keyed (a compiled lambda captures stuff at compile time from the compile time value of *locale*)
- ;; and the cache must be properly locked to support threading.
- (funcall pattern-compiler pattern))
- (function pattern))
- stream number)
- t)
- (named-lambda %format-number/visitor (stream locale)
- (awhen (or (getf (funcall formatter-accessor locale) verbosity)
- (getf (funcall formatter-accessor locale) nil))
- (bind ((formatter (getf it :formatter)))
- (if formatter
- (progn
- (funcall formatter stream number)
- t)
- nil)))))
- (named-lambda %format-number/fallback (stream)
- (warn "No ~A was found with verbosity ~S for locale ~A. Ignoring the locale and printing in a fixed simple format."
- formatter-name verbosity (current-locale))
- (cl:format stream fallback-format-pattern number))))
+ (etypecase pattern
+ (compiled-pattern
+ (with-normalized-stream-variable stream
+ (funcall pattern stream number)))
+ (string
+ (with-normalized-stream-variable stream
+ (funcall (funcall pattern-compiler pattern) stream number)))
+ (null
+ (%format-iterating-locales
+ stream
+ (named-lambda %format-number/visitor (stream locale)
+ (bind ((entry (or (assoc-value (funcall formatter-accessor locale) verbosity)
+ (assoc-value (funcall formatter-accessor locale) nil)))
+ (formatter (getf entry :formatter)))
+ (if formatter
+ (progn
+ (funcall formatter stream number)
+ t)
+ nil)))
+ (named-lambda %format-number/fallback (stream)
+ (warn "No ~A was found with verbosity ~S for locale ~A. Ignoring the locale and printing in a fixed simple format."
+ formatter-name verbosity (current-locale))
+ (cl:format stream fallback-format-pattern number))))))
(defun format-number/decimal (stream number &key (verbosity 'ldml:medium) pattern)
(%format-number stream number verbosity
diff -rN -u old-cl-l10n/src/i18n.lisp new-cl-l10n/src/i18n.lisp
--- old-cl-l10n/src/i18n.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/i18n.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -15,9 +15,9 @@
(cl:format stream "The resource ~S is missing for ~A"
(name-of condition) (locale-of condition)))))
-(defun resource-missing (name)
+(defun resource-missing (name &optional (return-value name))
(warn 'resource-missing :name name)
- name)
+ return-value)
(defun ensure-resource-lookup-stub (name)
(unless (get name 'resource-lookup-stub)
@@ -216,37 +216,39 @@
(defun-with-capitalizer cl-l10n.lang:localize-currency-symbol (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (currencies-of locale))
- (return (values (second it) t)))))
+ (awhen (symbol-of it)
+ (return (values it t))))))
(defun-with-capitalizer cl-l10n.lang:localize-currency-name (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (currencies-of locale))
- (return (values (first it) t)))))
+ (awhen (long-name-of it)
+ (return (values it t))))))
(defun-with-capitalizer cl-l10n.lang:localize-language-name (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (languages-of locale))
(return (values it t)))))
(defun-with-capitalizer cl-l10n.lang:localize-script-name (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (scripts-of locale))
(return (values it t)))))
(defun-with-capitalizer cl-l10n.lang:localize-territory-name (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (territories-of locale))
(return (values it t)))))
(defun-with-capitalizer cl-l10n.lang:localize-variant-name (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (gethash name (variants-of locale))
(return (values it t)))))
@@ -260,7 +262,7 @@
(unless (and index
(<= 0 index 11))
(error "~S is not a valid month name, it should be either an integer between 0 and 11 or a symbol like 'CL-L10N.LDML:JANUARY" name))
- (do-current-locales-for-resource "<a month name>" locale
+ (do-current-locales-for-resource ("<a month name>" locale)
(when-bind calendar (gregorian-calendar-of locale)
(when-bind vector (if abbreviated
(abbreviated-month-names-of calendar)
@@ -277,7 +279,7 @@
(unless (and index
(<= 0 index 6))
(error "~S is not a valid day name, it should be either an integer between 0 and 6 (0 is Sunday) or a symbol like 'CL-L10N.LDML:SUNDAY" name))
- (do-current-locales-for-resource "<a day name>" locale
+ (do-current-locales-for-resource ("<a day name>" locale)
(when-bind calendar (gregorian-calendar-of locale)
(when-bind vector (if abbreviated
(abbreviated-day-names-of calendar)
@@ -293,7 +295,7 @@
(unless (and index
(<= 0 index 3))
(error "~S is not a valid quarter name, it should be either an integer between 0 and 3 or a symbol like 'CL-L10N.LDML:FIRST-QUARTER" name))
- (do-current-locales-for-resource "<a quarter name>" locale
+ (do-current-locales-for-resource ("<a quarter name>" locale)
(when-bind calendar (gregorian-calendar-of locale)
(when-bind vector (if abbreviated
(abbreviated-quarter-names-of calendar)
@@ -303,7 +305,7 @@
(defun-with-capitalizer cl-l10n.lang:localize-number-symbol (name)
(assert (ldml-symbol-p name))
- (do-current-locales-for-resource name locale
+ (do-current-locales-for-resource (name locale)
(awhen (assoc name (number-symbols-of locale) :test #'eq)
(return (values (cdr it) t)))))
diff -rN -u old-cl-l10n/src/locale.lisp new-cl-l10n/src/locale.lisp
--- old-cl-l10n/src/locale.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/locale.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -79,6 +79,27 @@
(print-unreadable-object (obj stream :type t :identity t)
(princ (locale-name obj) stream)))
+(defclass currency ()
+ ((code
+ :initform (required-arg :code)
+ :initarg :code
+ :accessor code-of)
+ (symbol
+ :initform nil
+ :initarg :symbol
+ :accessor symbol-of)
+ (long-name
+ :initform nil
+ :initarg :long-name
+ :accessor long-name-of)))
+
+(defun ensure-currency (locale code)
+ (bind ((currency (gethash code (currencies-of locale))))
+ (unless currency
+ (setf currency (make-instance 'currency :code code))
+ (setf (gethash code (currencies-of locale)) currency))
+ currency))
+
(defgeneric locale-name (locale &key ignore-script ignore-territory ignore-variant)
(:method ((locale locale) &key ignore-variant ignore-territory ignore-script)
(let ((*print-pretty* nil))
diff -rN -u old-cl-l10n/src/pattern-compiling.lisp new-cl-l10n/src/pattern-compiling.lisp
--- old-cl-l10n/src/pattern-compiling.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/pattern-compiling.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -3,6 +3,16 @@
(in-package :cl-l10n)
+(defclass compiled-pattern (closer-mop:funcallable-standard-object)
+ ()
+ (:metaclass closer-mop:funcallable-standard-class))
+
+(defmacro make-compiled-pattern (args &body body)
+ (with-unique-names (result)
+ `(bind ((,result (make-instance 'compiled-pattern)))
+ (closer-mop:set-funcallable-instance-function ,result (lambda ,args ,@body))
+ ,result)))
+
;;; http://www.unicode.org/reports/tr35/tr35-11.html#Date_Format_Patterns
(define-constant +date-pattern-characters/gregorian-calendar+ "GyYuQqMLlwWdDFgEec" :test #'string=)
(define-constant +time-pattern-characters/gregorian-calendar+ "ahHKkjmsSAzZvV" :test #'string=)
@@ -142,7 +152,7 @@
(aif (position-if #'digit-char-p integer-part-without-grouping)
(- (length integer-part-without-grouping) it)
0))))
- (lambda (number)
+ (make-compiled-pattern (number)
(declare (inline digit-char)
(optimize speed))
(setf number (abs number))
@@ -225,6 +235,7 @@
(coerce formatted-digits 'string)))))))))))))
(defun compile-number-pattern/decimal (pattern)
+ (check-type pattern string)
(bind ((pos-subpat-prefix nil)
(pos-subpat-suffix nil)
(neg-subpat-prefix nil)
@@ -288,7 +299,8 @@
(setf neg-subpat-prefix (concatenate 'string pos-subpat-prefix "-"))
(setf neg-subpat-suffix pos-subpat-suffix))
- (lambda (stream number)
+ (make-compiled-pattern (stream number)
+ (check-type stream stream)
(bind ((prefix (if (minusp number) neg-subpat-prefix pos-subpat-prefix))
(suffix (if (minusp number) neg-subpat-suffix pos-subpat-suffix))
(formatted-number (funcall number-formatter number))
@@ -311,10 +323,12 @@
(write-string padding stream)))))))
(defun compile-number-pattern/percent (pattern)
+ (check-type pattern string)
;; TODO localize percent
(bind ((pattern (replace-percent-considering-quotes pattern "%"))
(formatter (compile-number-pattern/decimal pattern)))
- (lambda (stream number)
+ (make-compiled-pattern (stream number)
+ (check-type stream stream)
(funcall formatter stream (* number 100)))))
@@ -453,7 +467,8 @@
(collect (piece-formatter (write-string piece stream))))))))))
(collect (piece-formatter (write-string outer-piece stream))))))
(nreversef piece-formatters)
- (push (named-lambda date/time-formatter (stream date)
+ (push (make-compiled-pattern (stream date)
+ (check-type stream stream)
;; TODO should we compare the value of *locale* at compile/runtime?
;; if yes, then check the other formatters, too!
(local-time:with-decoded-timestamp (:year year :month month :day day :day-of-week day-of-week
@@ -474,100 +489,125 @@
(unit-pattern
:initform nil
:accessor unit-pattern-of)
- (pattern-verbosity-list
+ (formatters
:initform nil
- :accessor pattern-verbosity-list-of)))
+ :accessor formatters-of)))
;; TODO for now, it's not implemented according to the cldr
-(defun compile-number-pattern/currency (pattern)
- (lambda (stream number currency-code)
+(defun compile-number-pattern/currency (pattern &key currency-symbol currency-long-name)
+ (check-type pattern string)
+ (make-compiled-pattern (stream number currency-code)
+ (check-type stream stream)
(assert (ldml-symbol-p currency-code))
- ;; OPTIMIZATION we could have some memoization here...
- (bind ((formatter (compile-number-pattern/decimal
- (replace-currency-sign-considering-quotes
- pattern
- (do-current-locales locale
- ;; TODO assert for a match here. check all usages all around...
- (awhen (gethash currency-code (currencies-of locale))
- (awhen (second it)
- (return it))))
- (symbol-name currency-code)
- (do-current-locales locale
- (awhen (gethash currency-code (currencies-of locale))
- (awhen (first it)
- (return it))))))))
- (funcall formatter stream number))))
-
-(defmacro replace-sign-considering-quotes (pattern char-to-replace &body body)
- ;; TODO user once-only to rebind
- `(bind ((pattern ,pattern)
- (char-to-replace ,char-to-replace))
- (flet ((char-at-? (pattern index character)
- (if (and (<= 0 index) (< index (length pattern)))
- (char= (elt pattern index) character)
- nil)))
- (macrolet ((collect-string (string)
- `(map 'list (lambda (c)
- (collect c)
- (if (char= c #\')
- (collect c))) ,string)))
- (coerce
- (iter (generating char :in-sequence pattern :with-index index)
- (with no-quote = t)
- (next char)
- (switch (char :test #'char=)
- (char-to-replace (if no-quote
- (progn
- (unless
- (and
- (char-at-? pattern (- index 1) #\')
- (bind ((pattern (subseq pattern 0 index))
- (match (mismatch pattern (make-string index :initial-element #\') :from-end t)))
- (and match (oddp (- index match)))))
- (collect #\'))
- ,@body
- (unless
- (and
- (char-at-? pattern (+ index 1) #\')
- (bind ((pattern (subseq pattern (+ index 1)))
- (length (length pattern))
- (match (mismatch pattern (make-string length :initial-element #\'))))
- (and match (oddp match))))
- (collect #\')))
- (collect char)))
- (#\' (setf no-quote (not no-quote))
- (unless
- (or
- (and no-quote
- (char-at-? pattern (+ index 1) char-to-replace)
- (bind ((pattern (subseq pattern 0 index))
- (match (mismatch pattern (make-string index :initial-element #\') :from-end t)))
- (and match (evenp (- index match)))))
- (and (not no-quote)
- (char-at-? pattern (- index 1) char-to-replace)
- (bind ((pattern (subseq pattern index))
- (length (length pattern))
- (match (mismatch pattern (make-string length :initial-element #\'))))
- (and match (oddp match)))))
- (collect #\')))
- (otherwise (collect char))))
- 'string)))))
+ ;; OPTIMIZATION we could have some memoization here, but dut to the late-bound currency-code we cannot just simply capture stuff from the compile-time *locale*...
+ (funcall (compile-number-pattern/decimal
+ (replace-currency-marker-in-pattern
+ pattern
+ (or currency-symbol
+ (do-current-locales locale
+ ;; TODO assert for a match here. check all usages all around...
+ (awhen (gethash currency-code (currencies-of locale))
+ (awhen (symbol-of it)
+ (return it)))))
+ (symbol-name currency-code)
+ (or currency-long-name
+ (do-current-locales locale
+ (awhen (gethash currency-code (currencies-of locale))
+ (awhen (long-name-of it)
+ (return it)))))))
+ stream number)))
-(defun replace-percent-considering-quotes (pattern localized-percent-string)
- (replace-sign-considering-quotes pattern #\%
- (collect-string localized-percent-string)))
+(defun find-replacement-marker-in-pattern (pattern marker-character &key (start 0) end)
+ (declare (optimize speed))
+ (check-type pattern string)
+ (check-type marker-character character)
+ (check-type start array-index)
+ (check-type end (or null array-index))
+ (block nil
+ (bind ((end (or end (length pattern)))
+ (index (1- start))
+ (first-match-index nil)
+ (number-of-matches 0))
+ (declare (type fixnum number-of-matches))
+ (labels ((finish ()
+ (return (values first-match-index number-of-matches)))
+ (current ()
+ (aref pattern index))
+ (peek ()
+ (if (< (1+ index) end)
+ (aref pattern (1+ index))
+ (values)))
+ (next (&optional (drying-allowed? t))
+ (incf index)
+ (unless (< index end)
+ (if drying-allowed?
+ (finish)
+ (error "~S: error while parsing pattern ~S starting from position ~A"
+ 'find-replacement-marker-in-pattern pattern start)))
+ (current))
+ (parse ()
+ (switch ((next) :test #'char=)
+ (#\'
+ (parse/in-quote))
+ (marker-character
+ (setf first-match-index index)
+ (incf number-of-matches)
+ (count-consecutive-matches))
+ (otherwise
+ (parse))))
+ (count-consecutive-matches ()
+ (if (char= (next) marker-character)
+ (progn
+ (incf number-of-matches)
+ (count-consecutive-matches))
+ (finish)))
+ (parse/in-quote ()
+ (case (next nil)
+ (#\'
+ (if (eql #\' (peek))
+ (progn
+ (next)
+ (parse/in-quote))
+ (parse)))
+ (otherwise (parse/in-quote)))))
+ (declare (inline current peek next))
+ (parse)))))
+
+(defmacro do-replacement-markers-in-pattern ((pattern marker-character match-index-var match-count-var &optional return-value) &body body)
+ `(bind ((,match-index-var 0)
+ (,match-count-var 0))
+ (loop
+ (setf (values ,match-index-var ,match-count-var)
+ (find-replacement-marker-in-pattern ,pattern ,marker-character
+ :start (+ ,match-index-var ,match-count-var)))
+ (if ,match-index-var
+ (progn
+ ,@body)
+ (return ,return-value)))))
-(defun replace-currency-sign-considering-quotes (pattern currency-symbol currency-code currency-long-name)
- (replace-sign-considering-quotes pattern #\¤
- (if (not (char-at-? pattern (+ index 1) char-to-replace))
- ;; currency symbol
- (collect-string currency-symbol)
- (progn
- (next char)
- (if (not (char-at-? pattern (+ index 1) char-to-replace))
- ;; international currency symbol (3 letter code)
- (collect-string currency-code)
- (progn
- ;; long form of decimal symbol
- (next char)
- (collect-string currency-long-name)))))))
+(defun replace-percent-considering-quotes (pattern localized-percent-string)
+ (bind ((replacement-marker #\%)
+ (piece-start 0))
+ (with-output-to-string (output)
+ (do-replacement-markers-in-pattern (pattern replacement-marker match-index match-count)
+ (assert (= match-count 1))
+ (write-string pattern output :start piece-start :end match-index)
+ (write-string localized-percent-string output)
+ (setf piece-start (+ match-index match-count))))))
+
+(defun replace-currency-marker-in-pattern (pattern currency-symbol international-currency-symbol currency-long-name)
+ (check-type currency-symbol string)
+ (check-type international-currency-symbol string)
+ (check-type currency-long-name string)
+ (bind ((replacement-marker #\¤)
+ (piece-start 0)
+ (*print-pretty* nil))
+ (with-output-to-string (output)
+ (do-replacement-markers-in-pattern (pattern replacement-marker match-index match-count)
+ (write-string pattern output :start piece-start :end match-index)
+ (write-string (ecase match-count
+ (1 currency-symbol)
+ (2 international-currency-symbol)
+ (3 currency-long-name))
+ output)
+ (setf piece-start (+ match-index match-count))))))
diff -rN -u old-cl-l10n/src/utils.lisp new-cl-l10n/src/utils.lisp
--- old-cl-l10n/src/utils.lisp 2014-07-30 22:26:46.000000000 -0700
+++ new-cl-l10n/src/utils.lisp 2014-07-30 22:26:46.000000000 -0700
@@ -110,9 +110,10 @@
`(do-locales (,var *locale*)
,@body))
-(defmacro do-current-locales-for-resource (name var &rest body)
+(defmacro do-current-locales-for-resource ((name var &key (return-value `(resource-missing ,name)))
+ &rest body)
"DO-LOCALES on *LOCALE* that calls RESOURCE-MISSING unless there's a non-local exit in its body."
- `(do-locales (,var *locale* (resource-missing ,name))
+ `(do-locales (,var *locale* ,return-value)
,@body))