summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haunt.scm64
1 files changed, 64 insertions, 0 deletions
diff --git a/haunt.scm b/haunt.scm
index 4cc47c1..18c5d3b 100644
--- a/haunt.scm
+++ b/haunt.scm
@@ -162,6 +162,70 @@
(with-syntax ((current-lingua (datum->syntax x 'current-lingua)))
#'(translated-msg msg current-lingua))))))
+(define (translated-multipart-msg msg lingua assoc)
+ "Looks up MSG for LINGUA via Gettext and returns a list of its parts.
+
+Parts are separated by two vertical bars ||. If a part is prefixed by
+a text followed by a vertical bar the text is looked up a lambda in
+the association list ASSOC. If found, the lambda is called on the
+remainder of the part and the result added to the list. If it is not
+found or there is no vertical bar, the entire part is added to the
+list."
+ (define (split-along-unescaped-matches str pattern)
+ "Splits along pattern unless pattern is escaped by a backslash."
+ (let loop ((remainder str) ; what to match with
+ (start 0)) ; where to start matching, used to ignore escaped matches
+ (let ((match (string-match pattern remainder start)))
+ (if match ; if there is a match:
+ (if (and
+ ;; if match not at the beginning
+ (not (= (match:start match) 0))
+ (eq? ; and escaped by a backslash
+ (string-ref
+ remainder
+ (- (match:start match) 1))
+ #\\))
+ ;; then continue matching after the escaped match:
+ (loop
+ (string-append ; the same as remainder but
+ (string-drop-right (match:prefix match) 1) ; drop backslash
+ (match:substring match)
+ (match:suffix match))
+ (- (match:end match) 1))
+ ;; otherwise:
+ (cons
+ ;; everything before the match
+ (match:prefix match)
+ (loop ; recursive call
+ (match:suffix match) ; on everything after the match
+ 0))) ; start matching at start
+ ;; if pattern did not match:
+ (list remainder)))))
+ (let ((msgstr-parts
+ (split-along-unescaped-matches
+ (translated-msg msg lingua)
+ "\\\|\\\|")))
+ (map
+ (lambda (msgstr-part)
+ (let* ((subparts
+ (split-along-unescaped-matches
+ msgstr-part
+ "\\\|"))
+ (part-lambda (assoc-ref assoc (car subparts)))
+ (args (cdr subparts)))
+ (if part-lambda
+ (apply part-lambda args)
+ msgstr-part)))
+ msgstr-parts)))
+
+(define-syntax __
+ (lambda (x)
+ "Gettext shorthand for multipart messages separated by || in the string."
+ (syntax-case x ()
+ ((__ msg assoc)
+ (with-syntax ((current-lingua (datum->syntax x 'current-lingua)))
+ #'(translated-multipart-msg msg current-lingua assoc))))))
+
(define (date->string-for-lingua date lingua)
"Custom date->string* variant that deals with lingua and my no longer common German language \
orthographic preferences."