211 lines
6.4 KiB
Scheme
211 lines
6.4 KiB
Scheme
;;
|
|
;; cal-month.scm
|
|
;;
|
|
;; Month processing support.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; 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>=?
|
|
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)
|
|
(and (cal-month? m)
|
|
(cal-month? n)
|
|
(or (< (cadr m) (cadr n))
|
|
(and (= (cadr m) (cadr n))
|
|
(< (caddr m) (caddr n))))))
|
|
|
|
;; Returns true if m is less than or equal n
|
|
(define (cal-month<=? m n)
|
|
(or (cal-month<? m n)
|
|
(cal-month=? m n)))
|
|
|
|
;; Returns true if m is greater than or equal to n
|
|
(define (cal-month>=? m n)
|
|
(not (cal-month<? m n)))
|
|
|
|
;; Returns true if m is greater than n
|
|
(define (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-month<? (cal-month<? `(,TAG-CAL-MONTH 2023 5) `(,TAG-CAL-MONTH 2023 6)))
|
|
(test-true cal-month<? (cal-month<? `(,TAG-CAL-MONTH 2022 12) `(,TAG-CAL-MONTH 2023 1)))
|
|
(test-false cal-month<? (cal-month<? `(,TAG-CAL-MONTH 2023 1) `(,TAG-CAL-MONTH 2023 1)))
|
|
(test-false cal-month<? (cal-month<? `(,TAG-CAL-MONTH 2023 1) `(,TAG-CAL-MONTH 2023 1)))
|
|
(test-true cal-month=? (cal-month=? `(,TAG-CAL-MONTH 2023 4) `(,TAG-CAL-MONTH 2023 4)))
|
|
(test-false cal-month=? (cal-month=? `(,TAG-CAL-MONTH 2023 4) `(,TAG-CAL-MONTH 2023 5)))
|
|
(test-eq? cal-month-diff (cal-month-diff `(,TAG-CAL-MONTH 2023 1) `(,TAG-CAL-MONTH 2023 2)) 1)
|
|
(test-eq? cal-month-diff (cal-month-diff `(,TAG-CAL-MONTH 2023 1) `(,TAG-CAL-MONTH 2023 12)) 11)
|
|
(test-eq? cal-month-diff (cal-month-diff `(,TAG-CAL-MONTH 2023 1) `(,TAG-CAL-MONTH 2022 2)) -11)
|
|
(test-eq? cal-month-add (cal-month-add `(,TAG-CAL-MONTH 2023 1) 2) `(,TAG-CAL-MONTH 2023 3))
|
|
(test-equal? iso-date->cal-month (iso-date->cal-month "2023-04-03") `(,TAG-CAL-MONTH 2023 4))
|
|
))
|
|
|
|
)
|