diff --git a/src/cal-month.scm b/src/cal-month.scm new file mode 100644 index 0000000..915dd62 --- /dev/null +++ b/src/cal-month.scm @@ -0,0 +1,211 @@ +;; +;; cal-month.scm +;; +;; Month processing support. +;; +;; ISC License +;; +;; Copyright 2023 Brmlab, z.s. +;; Dominik Pantůček +;; +;; Permission to use, copy, modify, and/or distribute this software +;; for any purpose with or without fee is hereby granted, provided +;; that the above copyright notice and this permission notice appear +;; in all copies. +;; +;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL +;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE +;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR +;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, +;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN +;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +;; + +(declare (unit cal-month)) + +(module + cal-month + ( + make-cal-month + + cal-month? + + cal-month-year + cal-month-month + + string->cal-month + cal-month->string + + cal-month=? + cal-month=? + cal-month>? + cal-month-diff + cal-month-add + iso-date->cal-month + cal-month-tests! + ) + + (import scheme + (chicken base) + (chicken string) + (chicken format) + util-tag + testing) + + ;; Type tag + (define TAG-CAL-MONTH (make-tag CAL-MONTH)) + + ;; Simple wrapper for creating month representation as a list. Can + ;; construct invalid months. + (define (make-cal-month y m) + (list TAG-CAL-MONTH y m)) + + ;; Returns true if given value is a valid calendar month. + (define (cal-month? v) + (and (list? v) + (not (null? v)) + (eq? TAG-CAL-MONTH (car v)) + (not (null? (cdr v))) + (integer? (cadr v)) + (not (null? (cddr v))) + (integer? (caddr v)) + (>= (cadr v) 1000) + (<= (cadr v) 9999) + (>= (caddr v) 1) + (<= (caddr v) 12))) + + ;; Accessors + (define cal-month-year cadr) + (define cal-month-month caddr) + + ;; Converts string in a format YYYY-MM to valid month. Returns #f if + ;; the conversion fails. + (define (string->cal-month s) + (let ((l (string-split s "-"))) + (if (or (not l) + (null? l) + (null? (cdr l)) + (not (null? (cddr l)))) + #f + (let ((y (string->number (car l))) + (m (string->number (cadr l)))) + (if (and y m) + (let ((M (make-cal-month y m))) + (if (cal-month? M) + M + #f)) + #f))))) + + ;; Formats (valid) month as YYYY-MM string + (define (cal-month->string M) + (if M + (if (cal-month? M) + (let ((y (cadr M)) + (m (caddr M))) + (sprintf "~A-~A~A" + y + (if (< m 10) "0" "") + m)) + (error 'string->month "Invalid month" M)) + "____-__")) + + ;; Returns true if both arguments are a valid month and are equal + (define (cal-month=? m n) + (and (cal-month? m) + (cal-month? n) + (eq? (cadr m) (cadr n)) + (eq? (caddr m) (caddr n)))) + + ;; Returns true if the first argument is a month in the past of the + ;; second argument month + (define (cal-month=? m n) + (not (cal-month? m n) + (not (cal-month<=? m n))) + + ;; Returns the number of months between from f and to t. The first + ;; month is included in the count, the last month is not. + (define (cal-month-diff f t) + (if (cal-month? f) + (if (cal-month? t) + (let ((F (+ (* (cadr f) 12) (caddr f) -1)) + (T (+ (* (cadr t) 12) (caddr t) -1))) + (- T F)) + (error 'month-diff "Second argument is not a valid month" t)) + (error 'month-diff "First argument is not a valid month" f))) + + ;; Returns a month n months after the month m. The number n defaults + ;; to 1. + (define (cal-month-add m . ns) + (let* ((n (if (null? ns) + 1 + (car ns))) + (mi (+ (* 12 (cadr m)) (caddr m) n -1))) + (make-cal-month (quotient mi 12) + (+ (remainder mi 12) 1)))) + + ;; Converts ISO date YYYY-MM-DD to single month + (define (iso-date->cal-month str) + (let ((lst (string-split str "-"))) + (if (or (not lst) + (null? lst) + (null? (cdr lst)) + (null? (cddr lst)) + (not (null? (cdddr lst)))) + #f + (let ((year (string->number (car lst))) + (mon (string->number (cadr lst)))) + (if (and year mon) + (let ((M (make-cal-month year mon))) + (if (cal-month? M) + M + #f)) + #f))))) + + ;; Performs self-tests of the month module. + (define (cal-month-tests!) + (run-tests + cal-month + (test-true cal-month? (cal-month? `(,TAG-CAL-MONTH 2023 5))) + (test-false cal-month? (cal-month? `(,TAG-CAL-MONTH 999 8))) + (test-false cal-month? (cal-month? `(,TAG-CAL-MONTH 2023 -5))) + (test-equal? string->cal-month (string->cal-month "2023-01") `(,TAG-CAL-MONTH 2023 1)) + (test-false string->cal-month (string->cal-month "2023-13")) + (test-false string->cal-month (string->cal-month "YYYY-01")) + (test-false string->cal-month (string->cal-month "2023-MMM")) + (test-equal? cal-month->string (cal-month->string `(,TAG-CAL-MONTH 2023 1)) "2023-01") + (test-exn cal-month->string (cal-month->string `(,TAG-CAL-MONTH 999 12))) + (test-exn cal-month->string (cal-month->string `(,TAG-CAL-MONTH 2023 13))) + (test-true cal-monthcal-month (iso-date->cal-month "2023-04-03") `(,TAG-CAL-MONTH 2023 4)) + )) + + )