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)))