brmlab/hackerbase
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Split out month module.

Browse source
This commit is contained in:
Dominik Pantůček 2023-03-13 20:07:54 +01:00
parent ecb1fb6264
commit 8cc6b8ac43
3 changed files with 149 additions and 104 deletions
Download patch file Download diff file Expand all files Collapse all files

107
brmsaptool-orig.scm
View file

@ -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!")