Re: How would we use BCP 47 strings in a simple way?
Lassi Kortela 02 Aug 2020 09:27 UTC
Here's some code. I feel quite dumb about all this BCP 47 stuff so it's
probably wrong in some major way, but is seems to work sensibly.
We should provide a general-purpose BCP 47 API and submit it as a
separate SRFI. SRFI 198 doesn't need to depend on it, but people who
make multilingual foreign error objects can use it instead of rolling
their own language lookup/filtering API.
----------------------------------------------------------------------
(import (scheme base) (scheme case-lambda) (scheme write))
(import (srfi 1) (srfi 13))
;;
(define (plist-get/default plist key default)
(let loop ((plist plist))
(cond ((not (and (pair? plist) (pair? (cdr plist))))
default)
((eqv? key (car plist))
(cadr plist))
(else (loop (cddr plist))))))
(define-record-type foreign-error
(%make-foreign-error plist)
foreign-error?
(plist %foreign-error-plist))
(define (make-foreign-error . plist)
(%make-foreign-error plist))
(define (foreign-error-ref ferr property . args)
(let* ((plist (%foreign-error-plist ferr))
(value (plist-get/default plist property #f)))
(if (procedure? value) (apply value args) value)))
;;
(define (bcp-47-filter alist language-tag)
(any (lambda (pair)
(and (or (not language-tag)
(string=? language-tag (car pair))
(string-prefix? language-tag
(string-append (car pair) "-")))
(cdr pair)))
alist))
(define (make-translated-error alist)
(make-foreign-error
'languages (map car alist)
'message (case-lambda
(()
(bcp-47-filter alist #f))
((language-tag)
(bcp-47-filter alist language-tag)))))
;;
(define (disp . xs) (for-each display xs) (newline))
(let ((e (make-translated-error
'(("en-US" . "Get your new radials at the tire center!")
("en-GB" . "Get your new radials at the tyre centre!")
("en-CA" . "Get your new radials at the tire centre!")))))
(disp (foreign-error-ref e 'languages))
(disp (foreign-error-ref e 'message "en-US"))
(disp (foreign-error-ref e 'message "en"))
(disp (foreign-error-ref e 'message)))
(import (scheme base) (scheme case-lambda) (scheme write))
(import (srfi 1) (srfi 13))
;;
(define (plist-get/default plist key default)
(let loop ((plist plist))
(cond ((not (and (pair? plist) (pair? (cdr plist))))
default)
((eqv? key (car plist))
(cadr plist))
(else (loop (cddr plist))))))
(define-record-type foreign-error
(%make-foreign-error plist)
foreign-error?
(plist %foreign-error-plist))
(define (make-foreign-error . plist)
(%make-foreign-error plist))
(define (foreign-error-ref ferr property . args)
(let* ((plist (%foreign-error-plist ferr))
(value (plist-get/default plist property #f)))
(if (procedure? value) (apply value args) value)))
;;
(define (bcp-47-filter alist language-tag)
(any (lambda (pair)
(and (or (not language-tag)
(string=? language-tag (car pair))
(string-prefix? language-tag
(string-append (car pair) "-")))
(cdr pair)))
alist))
(define (make-translated-error alist)
(make-foreign-error
'languages (map car alist)
'message (case-lambda
(()
(bcp-47-filter alist #f))
((language-tag)
(bcp-47-filter alist language-tag)))))
;;
(define (disp . xs) (for-each display xs) (newline))
(let ((e (make-translated-error
'(("en-US" . "Get your new radials at the tire center!")
("en-GB" . "Get your new radials at the tyre centre!")
("en-CA" . "Get your new radials at the tire centre!")))))
(disp (foreign-error-ref e 'languages))
(disp (foreign-error-ref e 'message "en-US"))
(disp (foreign-error-ref e 'message "en"))
(disp (foreign-error-ref e 'message)))