Split out month module.
This commit is contained in:
parent
ecb1fb6264
commit
8cc6b8ac43
3 changed files with 149 additions and 104 deletions
|
|
@ -30,7 +30,10 @@
|
|||
(chicken sort)
|
||||
(chicken time)
|
||||
(chicken time posix)
|
||||
(chicken process-context))
|
||||
(chicken process-context)
|
||||
testing
|
||||
dictionary
|
||||
month)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Static default configuration
|
||||
|
|
@ -62,106 +65,6 @@
|
|||
(display ".")
|
||||
(error 'unit-test name)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Dictionary
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Months support
|
||||
|
||||
;; Returns true if this is a valid month representation - a list with
|
||||
;; two integer elements within the allowed range.
|
||||
(define (month-valid? m)
|
||||
(and (list? m)
|
||||
(car m)
|
||||
(cdr m)
|
||||
(cadr m)
|
||||
(null? (cddr m))
|
||||
(integer? (car m))
|
||||
(integer? (cadr m))
|
||||
(>= (car m) 1000)
|
||||
(<= (car m) 9999)
|
||||
(>= (cadr m) 1)
|
||||
(<= (cadr m) 12)))
|
||||
|
||||
;; Converts string in a format YYYY-MM to valid month. Returns #f if
|
||||
;; the conversion fails.
|
||||
(define (string->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 (list y m)))
|
||||
(if (month-valid? M)
|
||||
M
|
||||
#f))
|
||||
#f)))))
|
||||
|
||||
;; Formats (valid) month as YYYY-MM string
|
||||
(define (month->string M)
|
||||
(if (month-valid? M)
|
||||
(let ((y (car M))
|
||||
(m (cadr 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 (month=? m n)
|
||||
(and (month-valid? m)
|
||||
(month-valid? n)
|
||||
(equal? m n)))
|
||||
|
||||
;; Returns true if the first argument is a month in the past of the
|
||||
;; second argument month
|
||||
(define (month<? m n)
|
||||
(and (month-valid? m)
|
||||
(month-valid? n)
|
||||
(or (< (car m) (car n))
|
||||
(and (= (car m) (car n))
|
||||
(< (cadr m) (cadr 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 (month-diff f t)
|
||||
(if (month-valid? f)
|
||||
(if (month-valid? t)
|
||||
(let ((F (+ (* (car f) 12) (cadr f)))
|
||||
(T (+ (* (car t) 12) (cadr t))))
|
||||
(- T F))
|
||||
(error 'month-diff "Second argument is not a valid month" t))
|
||||
(error 'month-diff "First argument is not a valid month" f)))
|
||||
|
||||
(define (month-tests!)
|
||||
(display "[test] month ")
|
||||
(unit-test 'month-valid? (month-valid? '(2023 5)))
|
||||
(unit-test 'month-valid?-bad-year (not (month-valid? '(999 8))))
|
||||
(unit-test 'month-valid?-bad-month (not (month-valid? '(2023 -5))))
|
||||
(unit-test 'string->month (equal? (string->month "2023-01") '(2023 1)))
|
||||
(unit-test 'string->month-bad-month (not (string->month "2023-13")))
|
||||
(unit-test 'string->month-nonumber-year (not (string->month "YYYY-01")))
|
||||
(unit-test 'string->month-nonumber-month (not (string->month "2023-MMM")))
|
||||
(unit-test 'month->string (equal? (month->string '(2023 1)) "2023-01"))
|
||||
(unit-test 'month->string-bad-year (with-handler (lambda (x) #t) (month->string '(999 12)) #f))
|
||||
(unit-test 'month->string-bad-month (with-handler (lambda (x) #t) (month->string '(2023 13)) #f))
|
||||
(unit-test 'month<? (month<? '(2023 5) '(2023 6)))
|
||||
(unit-test 'month<?-cross-year (month<? '(2022 12) '(2023 1)))
|
||||
(unit-test 'month<?-is-equal (not (month<? '(2023 1) '(2023 1))))
|
||||
(unit-test 'month<?-greater (not (month<? '(2023 1) '(2023 1))))
|
||||
(unit-test 'month-equal? (month=? '(2023 4) '(2023 4)))
|
||||
(unit-test 'month-equal?-not (not (month=? '(2023 4) '(2023 5))))
|
||||
(unit-test 'month-diff-1 (= (month-diff '(2023 1) '(2023 2)) 1))
|
||||
(unit-test 'month-diff-11 (eq? (month-diff '(2023 1) '(2023 12)) 11))
|
||||
(unit-test 'month-diff (= (month-diff '(2023 1) '(2022 2)) -11))
|
||||
(print " ok."))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Periods
|
||||
|
||||
|
|
@ -594,7 +497,7 @@
|
|||
|
||||
;; Run tests
|
||||
(print "Running self-tests:")
|
||||
(dict-tests!)
|
||||
(dictionary-tests!)
|
||||
(month-tests!)
|
||||
(period-tests!)
|
||||
(print "All self-tests ok!")
|
||||
|
|
|
|||
|
|
@ -25,12 +25,15 @@
|
|||
|
||||
(import testing
|
||||
listing
|
||||
dictionary)
|
||||
dictionary
|
||||
month)
|
||||
|
||||
;; Print banner
|
||||
(print "brmsaptool 0.1 (c) 2023 Brmlab, z.s.")
|
||||
(print "brmsaptool 0.2 (c) 2023 Brmlab, z.s.")
|
||||
(newline)
|
||||
|
||||
;; Run tests
|
||||
(listing-tests!)
|
||||
(dictionary-tests!)
|
||||
(month-tests!)
|
||||
(newline)
|
||||
|
|
|
|||
139
month.scm
Normal file
139
month.scm
Normal file
|
|
@ -0,0 +1,139 @@
|
|||
;;
|
||||
;; 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.
|
||||
;;
|
||||
|
||||
(module
|
||||
month
|
||||
(
|
||||
month-valid?
|
||||
string->month
|
||||
month->string
|
||||
month=?
|
||||
month<?
|
||||
month-diff
|
||||
month-tests!
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken string)
|
||||
(chicken format)
|
||||
testing)
|
||||
|
||||
;; Returns true if this is a valid month representation - a list with
|
||||
;; two integer elements within the allowed range.
|
||||
(define (month-valid? m)
|
||||
(and (list? m)
|
||||
(car m)
|
||||
(cdr m)
|
||||
(cadr m)
|
||||
(null? (cddr m))
|
||||
(integer? (car m))
|
||||
(integer? (cadr m))
|
||||
(>= (car m) 1000)
|
||||
(<= (car m) 9999)
|
||||
(>= (cadr m) 1)
|
||||
(<= (cadr m) 12)))
|
||||
|
||||
;; Converts string in a format YYYY-MM to valid month. Returns #f if
|
||||
;; the conversion fails.
|
||||
(define (string->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 (list y m)))
|
||||
(if (month-valid? M)
|
||||
M
|
||||
#f))
|
||||
#f)))))
|
||||
|
||||
;; Formats (valid) month as YYYY-MM string
|
||||
(define (month->string M)
|
||||
(if (month-valid? M)
|
||||
(let ((y (car M))
|
||||
(m (cadr 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 (month=? m n)
|
||||
(and (month-valid? m)
|
||||
(month-valid? n)
|
||||
(equal? m n)))
|
||||
|
||||
;; Returns true if the first argument is a month in the past of the
|
||||
;; second argument month
|
||||
(define (month<? m n)
|
||||
(and (month-valid? m)
|
||||
(month-valid? n)
|
||||
(or (< (car m) (car n))
|
||||
(and (= (car m) (car n))
|
||||
(< (cadr m) (cadr 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 (month-diff f t)
|
||||
(if (month-valid? f)
|
||||
(if (month-valid? t)
|
||||
(let ((F (+ (* (car f) 12) (cadr f)))
|
||||
(T (+ (* (car t) 12) (cadr t))))
|
||||
(- T F))
|
||||
(error 'month-diff "Second argument is not a valid month" t))
|
||||
(error 'month-diff "First argument is not a valid month" f)))
|
||||
|
||||
;; Performs self-tests of the month module.
|
||||
(define (month-tests!)
|
||||
(run-tests
|
||||
month
|
||||
(test-true month-valid? (month-valid? '(2023 5)))
|
||||
(test-false month-valid? (month-valid? '(999 8)))
|
||||
(test-false month-valid? (month-valid? '(2023 -5)))
|
||||
(test-equal? string->month (string->month "2023-01") '(2023 1))
|
||||
(test-false string->month (string->month "2023-13"))
|
||||
(test-false string->month (string->month "YYYY-01"))
|
||||
(test-false string->month (string->month "2023-MMM"))
|
||||
(test-equal? month->string (month->string '(2023 1)) "2023-01")
|
||||
(test-exn month->string (month->string '(999 12)))
|
||||
(test-exn month->string (month->string '(2023 13)))
|
||||
(test-true month<? (month<? '(2023 5) '(2023 6)))
|
||||
(test-true month<? (month<? '(2022 12) '(2023 1)))
|
||||
(test-false month<? (month<? '(2023 1) '(2023 1)))
|
||||
(test-false month<? (month<? '(2023 1) '(2023 1)))
|
||||
(test-true month=? (month=? '(2023 4) '(2023 4)))
|
||||
(test-false month=? (month=? '(2023 4) '(2023 5)))
|
||||
(test-eq? month-diff (month-diff '(2023 1) '(2023 2)) 1)
|
||||
(test-eq? month-diff (month-diff '(2023 1) '(2023 12)) 11)
|
||||
(test-eq? month-diff (month-diff '(2023 1) '(2022 2)) -11)
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue