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

 )