;;
;; 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 month))

(module
 month
 (
  make-month
  month-year
  month-month
  month-valid?
  string->month
  month->string
  month=?
  month<?
  month<=?
  month>=?
  month>?
  month-diff
  month-add
  month-tests!
  )

 (import scheme
	 (chicken base)
	 (chicken string)
	 (chicken format)
	 testing)

 ;; Simple wrapper for creating month representation as a list.
 (define (make-month y m)
   (list y m))

 ;; Accessors
 (define month-year car)
 (define month-month cadr)

 ;; 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 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 true if m is less than or equal n
 (define (month<=? m n)
   (or (month<? m n)
       (month=? m n)))

 ;; Returns true if m is greater than or equal to n
 (define (month>=? m n)
   (not (month<? m n)))

 ;; Returns true if m is greater than n
 (define (month>? m n)
   (not (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 (month-diff f t)
   (if (month-valid? f)
       (if (month-valid? t)
	   (let ((F (+ (* (car f) 12) (cadr f) -1))
		 (T (+ (* (car t) 12) (cadr 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 (month-add m . ns)
   (let* ((n (if (null? ns)
		 1
		 (car ns)))
	  (mi (+ (* 12 (car m)) (cadr m) n -1)))
     (list (quotient mi 12)
	   (+ (remainder mi 12) 1))))

 ;; 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)
    (test-eq? month-add (month-add '(2023 1) 2) '(2023 3))
    ))

 )