From 3c9b8911b5952afe6ad69d04fbcbb7169bb0db3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 22 Feb 2022 18:02:12 +0100 Subject: Fix modularization of recurrence display. --- module/hnh/util/language.scm | 14 +++ module/vcomponent/recurrence/display.scm | 154 ++---------------------- module/vcomponent/recurrence/display/common.scm | 6 + module/vcomponent/recurrence/display/en.scm | 131 ++++++++++++++++++++ module/vcomponent/recurrence/display/sv.scm | 139 +++++++++++++++++++++ 5 files changed, 299 insertions(+), 145 deletions(-) create mode 100644 module/hnh/util/language.scm create mode 100644 module/vcomponent/recurrence/display/common.scm create mode 100644 module/vcomponent/recurrence/display/en.scm create mode 100644 module/vcomponent/recurrence/display/sv.scm (limited to 'module') diff --git a/module/hnh/util/language.scm b/module/hnh/util/language.scm new file mode 100644 index 00000000..9b61483c --- /dev/null +++ b/module/hnh/util/language.scm @@ -0,0 +1,14 @@ +(define-module (hnh util language) + :export (resolve-language)) + + +;; Locale objects, such as %global-locale, doesn't provide a way to access the language name, +;; This is for procedures which want to handle their translations manually. +(define (resolve-language) + "Returns a two character symbol representing the \"current\" language. e.g. en" + (string->symbol + (string-take + (or (getenv "LC_MESSAGES") + (getenv "LC_ALL") + "en") + 2))) diff --git a/module/vcomponent/recurrence/display.scm b/module/vcomponent/recurrence/display.scm index f5ce1c57..8a9f33e6 100644 --- a/module/vcomponent/recurrence/display.scm +++ b/module/vcomponent/recurrence/display.scm @@ -1,146 +1,10 @@ -;;; Commentary: -;; Pretty print a recurrence rule (in Swedish). Is currently missing a -;; number of ;; edge cases, and even more concerning limited events. -;; NOTE It would be preferable if this could share as much logic as possible -;; with the "real" generator. -;;; Code: - (define-module (vcomponent recurrence display) - :use-module (hnh util) - :use-module (vcomponent recurrence internal) - :use-module (text util) - :use-module (text numbers sv) - :use-module ((datetime) :select (time time->string - datetime->string - week-day-name - locale-month - )) - ) - - -(define (rrule-month->string n) - (locale-month n)) - -;; TODO this currently only groups on offsets, but not on days. -;; So 1MO, 1TU becomes "första måndagen och tisdagen", which is good -;; but 1MO, -1MO doesn't become "första och sista måndagen". -;; TODO also, grouping of -dagen. e.g. "första mån- och tisdagen" -(define (format-byday-list lst) - (let* ((groups (group-by car lst))) - (intersperse - " samt " - (map (lambda (group) - ;; TODO sort week days - (case (car group) - [(#f) - (list "varje " - (add-enumeration-punctuation - (map (lambda (d) (list (week-day-name (cdr d)))) - (cadr group) - )))] - [else - (list (number->string-ordinal - (car group) - a-form?: #t) - " " - (add-enumeration-punctuation - (map (lambda (d) (list (week-day-name (cdr d)) "en")) - (cadr group))))]) - ) - groups)))) - -(define* (format-bymonth-day lst optional: (final-delim "&")) - (list "den " - (add-enumeration-punctuation - (map number->string-ordinal lst) - final-delim))) - - -(define-public (format-recurrence-rule rrule) - (string-trim - (string-flatten - (list - (case (freq rrule) - [(YEARLY) - (list (awhen (byday rrule) (list " " (format-byday-list it))) - (awhen (bymonthday rrule) (list " " (format-bymonth-day it "eller"))) - (awhen (byyearday rrule) - (list " dag " (add-enumeration-punctuation it))) - (awhen (bymonth rrule) - ;; only `i' here if we have output something else beforehand - (list (when (or (byday rrule) - (bymonthday rrule) - (byyearday rrule)) - " i ") - (add-enumeration-punctuation - (map rrule-month->string it)))) - (awhen (byweekno rrule) - (map (lambda (v) (format #f " v.~a" v)) it)) - )] - [(MONTHLY) - (list - (awhen (byday rrule) (list (format-byday-list it))) - (awhen (bymonthday rrule) (cons " " (format-bymonth-day it))))] - [else '()]) - - ;; TODO my parser adds an implicit interval to every object - ;; this might be wrong - (cond [(and (eq? 'DAILY (freq rrule)) (= 1 (interval rrule))) - " dagligen"] - [(and (eq? 'YEARLY (freq rrule)) (= 1 (interval rrule))) - ", årligen"] - [(and (eq? 'MINUTELY (freq rrule)) - (zero? (modulo (interval rrule) 15))) - (list " " - (each-string (/ (interval rrule) 15)) - " kvart")] - [else - (list - " " - (each-string (interval rrule) (eq? 'YEARLY (freq rrule))) - " " - (case (freq rrule) - ;; p.44 RFC 5545 - [(SECONDLY) "sekund"] - [(MINUTELY) "minut"] - [(HOURLY) "timme"] - [(DAILY) "dag"] - - ;; day offsets CAN ONLY be present when FREQ is - ;; either MONTHLY or YEARLY - [(WEEKLY) (aif (byday rrule) - (add-enumeration-punctuation - (map (compose week-day-name cdr) it)) - "vecka")] - [(MONTHLY) "månad"] - [(YEARLY) "år"] - [else "ERROR"] - ))]) - - (cond [(and (byminute rrule) - (byhour rrule)) - (list - " kl. " - (add-enumeration-punctuation - (map (lambda (pair) - (time->string - (time hour: (car pair) - minute: (cadr pair)) - "~H:~M")) - (cross-product (byhour rrule) - (byminute rrule)))))] - [(byhour rrule) - => (lambda (hours) - (list " kl. " (add-enumeration-punctuation hours)))] - [else '()]) - - (awhen (until rrule) - (format #f ", till och med ~a" - (datetime->string - ;; TODO ordinal on ~d? - it "den ~d ~B, ~Y kl. ~k:~M") - )) - (cond [(not (count rrule)) ""] - [(= 1 (count rrule)) (list ", totalt " (count rrule) " gång")] - [(count rrule) (list ", totalt " (count rrule) " gånger")] - [else "ERROR"]))))) + :use-module (vcomponent recurrence display common) + :use-module (hnh util language) + :re-export (rrule-month->string) + :export (format-recurrence-rule)) + +(define* (format-recurrence-rule rrule #:optional (language (resolve-language))) + ((module-ref (resolve-interface `(vcomponent recurrence display ,language)) + 'format-recurrence-rule) + rrule)) diff --git a/module/vcomponent/recurrence/display/common.scm b/module/vcomponent/recurrence/display/common.scm new file mode 100644 index 00000000..c9d0f5e1 --- /dev/null +++ b/module/vcomponent/recurrence/display/common.scm @@ -0,0 +1,6 @@ +(define-module (vcomponent recurrence display common) + :use-module ((datetime) :select (locale-month)) + :export (rrule-month->string)) + +(define (rrule-month->string n) + (locale-month n)) diff --git a/module/vcomponent/recurrence/display/en.scm b/module/vcomponent/recurrence/display/en.scm new file mode 100644 index 00000000..be9bdf53 --- /dev/null +++ b/module/vcomponent/recurrence/display/en.scm @@ -0,0 +1,131 @@ +(define-module (vcomponent recurrence display en) + :use-module (hnh util) + :use-module (vcomponent recurrence internal) + :use-module (text util) + :use-module (text numbers) + :use-module (vcomponent recurrence display common) + :use-module ((datetime) :select (time time->string + datetime->string + week-day-name))) + + + +;; TODO this currently only groups on offsets, but not on days. +;; So 1MO, 1TU becomes "första måndagen och tisdagen", which is good +;; but 1MO, -1MO doesn't become "första och sista måndagen". +;; TODO also, grouping of -dagen. e.g. "första mån- och tisdagen" +(define (format-byday-list lst) + (let* ((groups (group-by car lst))) + (intersperse + " as well as " + (map (lambda (group) + ;; TODO sort week days + (case (car group) + [(#f) + (list "every " + (add-enumeration-punctuation + (map (lambda (d) (list (week-day-name (cdr d)))) + (cadr group) + )))] + [else + (list (number->string-ordinal (car group)) " " + (add-enumeration-punctuation + (map (lambda (d) (list (week-day-name (cdr d)) "en")) + (cadr group))))]) + ) + groups)))) + +(define (format-bymonth-day lst) + (list "the " + (add-enumeration-punctuation + (map number->string-ordinal lst)))) + + +(define-public (format-recurrence-rule rrule) + (string-trim + (string-flatten + (list + (case (freq rrule) + [(YEARLY) + (list (awhen (byday rrule) (list " " (format-byday-list it))) + (awhen (bymonthday rrule) (list " " (format-bymonth-day it))) + (awhen (byyearday rrule) + (list " day " (add-enumeration-punctuation it))) + (awhen (bymonth rrule) + ;; only `i' here if we have output something else beforehand + (list (when (or (byday rrule) + (bymonthday rrule) + (byyearday rrule)) + " in ") + (add-enumeration-punctuation + (map rrule-month->string it)))) + (awhen (byweekno rrule) + (map (lambda (v) (format #f " v.~a" v)) it)) + )] + [(MONTHLY) + (list + (awhen (byday rrule) (list (format-byday-list it))) + (awhen (bymonthday rrule) (format-bymonth-day it)))] + [else '()]) + + ;; TODO my parser adds an implicit interval to every object + ;; this might be wrong + (cond [(and (eq? 'DAILY (freq rrule)) (= 1 (interval rrule))) + " daily"] + [(and (eq? 'YEARLY (freq rrule)) (= 1 (interval rrule))) + ", yearly"] + [(and (eq? 'MINUTELY (freq rrule)) + (zero? (modulo (interval rrule) 15))) + (list " " + (each-string (/ (interval rrule) 15)) + " 15 minutes")] + [else + (list + " " + (each-string (interval rrule) (eq? 'YEARLY (freq rrule))) + " " + (case (freq rrule) + ;; p.44 RFC 5545 + [(SECONDLY) "second"] + [(MINUTELY) "minute"] + [(HOURLY) "hour"] + [(DAILY) "day"] + + ;; day offsets CAN ONLY be present when FREQ is + ;; either MONTHLY or YEARLY + [(WEEKLY) (aif (byday rrule) + (add-enumeration-punctuation + (map (compose week-day-name cdr) it)) + "week")] + [(MONTHLY) "month"] + [(YEARLY) "year"] + [else "ERROR"] + ))]) + + (cond [(and (byminute rrule) + (byhour rrule)) + (list + " at " + (add-enumeration-punctuation + (map (lambda (pair) + (time->string + (time hour: (car pair) + minute: (cdr pair)) + "~H:~M")) + (cross-product (byhour rrule) + (byminute rrule)))))] + [(byhour rrule) + => (lambda (hours) + (list " at " (add-enumeration-punctuation hours)))] + [else '()]) + + (awhen (until rrule) + (format #f ", until ~a" + (datetime->string + ;; TODO ordinal on ~d? + it "~B ~d, ~Y at ~k:~M") + )) + (cond [(not (count rrule)) ""] + [(= 1 (count rrule)) (list ", " (count rrule) " time in total")] + [(count rrule) (list ", " (count rrule) " times in total")] + [else "ERROR"]))))) diff --git a/module/vcomponent/recurrence/display/sv.scm b/module/vcomponent/recurrence/display/sv.scm new file mode 100644 index 00000000..fe580474 --- /dev/null +++ b/module/vcomponent/recurrence/display/sv.scm @@ -0,0 +1,139 @@ +;;; Commentary: +;; Pretty print a recurrence rule (in Swedish). Is currently missing a +;; number of ;; edge cases, and even more concerning limited events. +;; NOTE It would be preferable if this could share as much logic as possible +;; with the "real" generator. +;;; Code: + +(define-module (vcomponent recurrence display sv) + :use-module (hnh util) + :use-module (vcomponent recurrence internal) + :use-module (text util) + :use-module (text numbers sv) + :use-module (vcomponent recurrence display common) + :use-module ((datetime) :select (time time->string + datetime->string + week-day-name))) + +;; TODO this currently only groups on offsets, but not on days. +;; So 1MO, 1TU becomes "första måndagen och tisdagen", which is good +;; but 1MO, -1MO doesn't become "första och sista måndagen". +;; TODO also, grouping of -dagen. e.g. "första mån- och tisdagen" +(define (format-byday-list lst) + (let* ((groups (group-by car lst))) + (intersperse + " samt " + (map (lambda (group) + ;; TODO sort week days + (case (car group) + [(#f) + (list "varje " + (add-enumeration-punctuation + (map (lambda (d) (list (week-day-name (cdr d)))) + (cadr group) + )))] + [else + (list (number->string-ordinal + (car group) + a-form?: #t) + " " + (add-enumeration-punctuation + (map (lambda (d) (list (week-day-name (cdr d)) "en")) + (cadr group))))]) + ) + groups)))) + +(define* (format-bymonth-day lst optional: (final-delim "&")) + (list "den " + (add-enumeration-punctuation + (map number->string-ordinal lst) + final-delim))) + +(define-public (format-recurrence-rule rrule) + (string-trim + (string-flatten + (list + (case (freq rrule) + [(YEARLY) + (list (awhen (byday rrule) (list " " (format-byday-list it))) + (awhen (bymonthday rrule) (list " " (format-bymonth-day it "eller"))) + (awhen (byyearday rrule) + (list " dag " (add-enumeration-punctuation it))) + (awhen (bymonth rrule) + ;; only `i' here if we have output something else beforehand + (list (when (or (byday rrule) + (bymonthday rrule) + (byyearday rrule)) + " i ") + (add-enumeration-punctuation + (map rrule-month->string it)))) + (awhen (byweekno rrule) + (map (lambda (v) (format #f " v.~a" v)) it)) + )] + [(MONTHLY) + (list + (awhen (byday rrule) (list (format-byday-list it))) + (awhen (bymonthday rrule) (cons " " (format-bymonth-day it))))] + [else '()]) + + ;; TODO my parser adds an implicit interval to every object + ;; this might be wrong + (cond [(and (eq? 'DAILY (freq rrule)) (= 1 (interval rrule))) + " dagligen"] + [(and (eq? 'YEARLY (freq rrule)) (= 1 (interval rrule))) + ", årligen"] + [(and (eq? 'MINUTELY (freq rrule)) + (zero? (modulo (interval rrule) 15))) + (list " " + (each-string (/ (interval rrule) 15)) + " kvart")] + [else + (list + " " + (each-string (interval rrule) (eq? 'YEARLY (freq rrule))) + " " + (case (freq rrule) + ;; p.44 RFC 5545 + [(SECONDLY) "sekund"] + [(MINUTELY) "minut"] + [(HOURLY) "timme"] + [(DAILY) "dag"] + + ;; day offsets CAN ONLY be present when FREQ is + ;; either MONTHLY or YEARLY + [(WEEKLY) (aif (byday rrule) + (add-enumeration-punctuation + (map (compose week-day-name cdr) it)) + "vecka")] + [(MONTHLY) "månad"] + [(YEARLY) "år"] + [else "ERROR"] + ))]) + + (cond [(and (byminute rrule) + (byhour rrule)) + (list + " kl. " + (add-enumeration-punctuation + (map (lambda (pair) + (time->string + (time hour: (car pair) + minute: (cadr pair)) + "~H:~M")) + (cross-product (byhour rrule) + (byminute rrule)))))] + [(byhour rrule) + => (lambda (hours) + (list " kl. " (add-enumeration-punctuation hours)))] + [else '()]) + + (awhen (until rrule) + (format #f ", till och med ~a" + (datetime->string + ;; TODO ordinal on ~d? + it "den ~d ~B, ~Y kl. ~k:~M") + )) + (cond [(not (count rrule)) ""] + [(= 1 (count rrule)) (list ", totalt " (count rrule) " gång")] + [(count rrule) (list ", totalt " (count rrule) " gånger")] + [else "ERROR"]))))) -- cgit v1.2.3