The ~V is supposed to print ISO week number, not a week number. This commit fixes that.
* module/srfi/srfi-19.scm (date-week-number-iso): New procedure taken from the reference implementation. (directives)<#\V>: Use it. * test-suite/tests/srfi-19.test ("date->string ~V"): Add tests taken from the reference test suite. * doc/ref/srfi-modules.texi (SRFI-19 Date to string): Mention ISO-8601 in description for ~V. --- doc/ref/srfi-modules.texi | 4 +-- module/srfi/srfi-19.scm | 24 +++++++++++++- test-suite/tests/srfi-19.test | 60 +++++++++++++++++++++++++++++++++-- 3 files changed, 83 insertions(+), 5 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index f072e6c3f..0b663902e 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2864,8 +2864,8 @@ with locale decimal point, eg.@: @samp{5.2} @item @nicode{~T} @tab time, 24 hour clock, @samp{~H:~M:~S} @item @nicode{~U} @tab week of year, Sunday first day of week, @samp{00} to @samp{52} -@item @nicode{~V} @tab week of year, Monday first day of week, -@samp{01} to @samp{53} +@item @nicode{~V} @tab ISO 8601 week number of the year, +Monday first day of week, @samp{01} to @samp{53} @item @nicode{~w} @tab day of week, 0 for Sunday, @samp{0} to @samp{6} @item @nicode{~W} @tab week of year, Monday first day of week, @samp{00} to @samp{52} diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index d809ac1ec..7ab0ad6dd 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -753,6 +753,28 @@ (days-before-first-week date day-of-week-starting-week)) 7)) +;;; Taken from the reference implementation. Modified to fit Guile's +;;; code style. +(define (date-week-number-iso date) + "Return a ISO-8601 week number for the @var{date}." + ;; The week with the year's first Thursday is week 01. + (let* ((first-day-of-the-week (week-day 1 1 (date-year date))) + (offset (if (> first-day-of-the-week 4) 0 1)) + ;; -2: decrement one day to compensate 1-origin of date-year-day, + ;; and decrement one more day for Sunday belongs to the previous week. + (w (+ (floor-quotient (+ (date-year-day date) first-day-of-the-week -2) + 7) + offset))) + (cond ((zero? w) + ;; date belongs to the last week of the previous year + (date-week-number-iso (make-date 0 0 0 0 31 12 + (- (date-year date) 1) 0))) + ((and (= w 53) + (<= (week-day 1 1 (+ (date-year date) 1)) 4)) + ;; date belongs to the first week of the next year + 1) + (else w)))) + (define (current-date . tz-offset) (let ((time (current-time time-utc))) (time-utc->date @@ -1043,7 +1065,7 @@ (display (padding (date-week-number date 0) #\0 2) port)))) (cons #\V (lambda (date pad-with port) - (display (padding (date-week-number date 1) + (display (padding (date-week-number-iso date) #\0 2) port))) (cons #\w (lambda (date pad-with port) (display (date-week-day date) port))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 55eb82320..3cacff669 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -26,7 +26,8 @@ #:use-module (test-suite lib) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:use-module (ice-9 format)) + #:use-module (ice-9 format) + #:use-module (ice-9 match)) ;; Make sure we use the default locale. (when (defined? 'setlocale) @@ -412,7 +413,62 @@ incomplete numerical tower implementation.)" (with-test-prefix "date-week-number" (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) - (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0))))) + (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))) + + (let ((convert (match-lambda + ((y m d) + (date->string (make-date 0 0 0 0 d m y 0) + "~V"))))) + ;; The test cases are taken from the test suite for the reference + ;; implementation. + (with-test-prefix "date->string ~V" + (pass-if-equal "Thursday, week 53" "53" + (convert '(2020 12 31))) + (pass-if-equal "Friday, week 53 (previous year)" "53" + (convert '(2021 1 1))) + (pass-if-equal "Sunday, week 53 (previous year)" "53" + (convert '(2021 1 3))) + (pass-if-equal "Monday, week 1" "01" + (convert '(2021 1 4))) + + (pass-if-equal "Sunday, week 52" "52" + (convert '(2019 12 29))) + (pass-if-equal "Monday, week 1 (next year)" "01" + (convert '(2019 12 30))) + (pass-if-equal "Tuesday, week 1 (next year)" "01" + (convert '(2019 12 31))) + (pass-if-equal "Wednesday, week 1" "01" + (convert '(2020 1 1))) + + (pass-if-equal "Saturday, week 52" "52" + (convert '(2016 12 31))) + (pass-if-equal "Sunday, week 52 (previous year)" "52" + (convert '(2017 1 1))) + (pass-if-equal "Monday, week 1" "01" + (convert '(2017 1 2))) + (pass-if-equal "Sunday, week 1" "01" + (convert '(2017 1 8))) + (pass-if-equal "Monday, week 2" "02" + (convert '(2017 1 9))) + + (pass-if-equal "Sunday, week 52" "52" + (convert '(2014 12 28))) + (pass-if-equal "Monday, week 1 (next year)" "01" + (convert '(2014 12 29))) + (pass-if-equal "Tuesday, week 1 (next year)" "01" + (convert '(2014 12 30))) + (pass-if-equal "Wednesday, week 1 (next year)" "01" + (convert '(2014 12 31))) + (pass-if-equal "Thursday, week 1" "01" + (convert '(2015 1 1))) + (pass-if-equal "Friday, week 1" "01" + (convert '(2015 1 2))) + (pass-if-equal "Saturday, week 1" "01" + (convert '(2015 1 3))) + (pass-if-equal "Sunday, week 1" "01" + (convert '(2015 1 4))) + (pass-if-equal "Monday, week 2" "02" + (convert '(2015 1 5)))))) ;; Local Variables: -- 2.47.1