Add tagged cal-month structure.
This commit is contained in:
parent
901806ad7a
commit
cd787c7319
1 changed files with 211 additions and 0 deletions
211
src/cal-month.scm
Normal file
211
src/cal-month.scm
Normal file
|
|
@ -0,0 +1,211 @@
|
|||
;;
|
||||
;; 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))
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue