diff --git a/brmsaptool-orig.scm b/brmsaptool-orig.scm index 56fdc3b..20ef568 100644 --- a/brmsaptool-orig.scm +++ b/brmsaptool-orig.scm @@ -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 (monthmonth (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 +;; +;; 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= (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 (monthmonth (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