;;; simple test procedures

(use srfi-19)
(use locale)    ;To force a locale
(use numbers)   ;Rational results from 'julian-day'
(use srfi-1)    ;For current-date w/o tz-locale test
(use format)    ;For conversion test

;;

#; ;Unused
(define (with-locale locstr thunk)
  (let ((curloc (current-locale)))
    (dynamic-wind
      (lambda () (current-locale locstr))
      thunk
      (lambda () (current-locale curloc))) ) )

;;

(define (display! x #!optional (p (current-output-port)))
  (display x p)
  (flush-output p) )

(define (newline! #!optional (p (current-output-port)))
  (newline p)
  (flush-output p) )

(define s19-tests (list))

(define (define-s19-test! name thunk)
  (let ((name (if (symbol? name) name (string->symbol name)))
        (pr (assoc name s19-tests)))
    (if pr
        (set-cdr! pr thunk)
        (set! s19-tests (append s19-tests (list (cons name thunk)))))))

(define (run-s19-test name thunk verbose)
  (if verbose (begin (display! ";;; Running ") (display! name)))
  (let ((result (thunk)))
    (if verbose (begin (display! ": ") (display! (not (not result))) (newline!)))
    result))

(define (run-s19-tests . verbose)
  (let ((runs 0) (goods 0) (bads 0) (verbose (and (not (null? verbose)) (car verbose))))
    (for-each (lambda (pr)
                (set! runs (+ runs 1))
                (if (run-s19-test (car pr) (cdr pr) verbose)
                    (set! goods (+ goods 1))
                    (set! bads (+ bads 1))))
              s19-tests)
    (if verbose
        (begin
          (display! ";;; Results: Runs: ")
          (display! runs)
          (display! "; Goods: ")
          (display! goods)
          (display! "; Bads: ")
          (display! bads)
          (if (> runs 0)
              (begin
                (display! "; Pass rate: ")
                (display! (/ goods runs)))
              (display! "; No tests."))
          (newline!)))
    (values runs goods bads)))

;;

(define-s19-test! "Creating time structures"
  (lambda ()
    (not (null? (list (current-time time-tai)
                      (current-time time-utc)
                      (current-time time-monotonic)
                      (current-time time-thread)
                      (current-time time-process))))))

(define-s19-test! "Testing time resolutions"
  (lambda ()
    (not (null? (list (time-resolution time-tai)
                      (time-resolution time-utc)
                      (time-resolution time-monotonic)
                      (time-resolution time-thread)
                      (time-resolution time-process))))))

(define-s19-test! "Time nanos positive"
  (lambda ()
    (and-let* ((ct (current-time))
               ((time? ct)) )
      (not (negative? (time-nanosecond ct))) ) ) )

(define-s19-test! "Time comparisons (time=?, etc.)"
  (lambda ()
    (let ((t1 (make-time time-utc 0 1))
          (t2 (make-time time-utc 0 1))
          (t3 (make-time time-utc 0 2))
          (t11 (make-time time-utc 1001 1))
          (t12 (make-time time-utc 1001 1))
          (t13 (make-time time-utc 1001 2)))
      (and (time=? t1 t2)
           (time>? t3 t2)
           (time<? t2 t3)
           (time>=? t1 t2)
           (time>=? t3 t2)
           (time<=? t1 t2)
           (time<=? t2 t3)
           (time=? t11 t12)
           (time>? t13 t12)
           (time<? t12 t13)
           (time>=? t11 t12)
           (time>=? t13 t12)
           (time<=? t11 t12)
           (time<=? t12 t13)
           ))))

(define-s19-test! "Time difference"
  (lambda ()
    (let ((t1 (make-time time-utc 0 3000))
          (t2 (make-time time-utc 0 1000))
          (t3 (make-time time-duration 0 2000))
          (t4 (make-time time-duration 0 -2000)))
      (and
       (time=? t3 (time-difference t1 t2))
       (time=? t4 (time-difference t2 t1))))))

(define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
  (let* (;; right on the edge they should be the same
         (utc-basic (make-time time-utc 0 utc))
         (tai-basic (make-time time-tai 0 (+ utc tai-diff)))
         (utc->tai-basic (time-utc->time-tai utc-basic))
         (tai->utc-basic (time-tai->time-utc tai-basic))
         ;; a second before they should be the old diff
         (utc-basic-1 (make-time time-utc 0 (- utc 1)))
         (tai-basic-1 (make-time time-tai 0 (- (+ utc tai-last-diff) 1)))
         (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
         (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
         ;; a second later they should be the new diff
         (utc-basic+1 (make-time time-utc 0 (+ utc 1)))
         (tai-basic+1 (make-time time-tai 0 (+ (+ utc tai-diff) 1)))
         (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
         (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
         ;; ok, let's move the clock half a month or so plus half a second
         (shy (* 15 24 60 60))
         (hs (/ (expt 10 9) 2))
         ;; a second later they should be the new diff
         (utc-basic+2 (make-time time-utc hs (+ utc shy)))
         (tai-basic+2 (make-time time-tai hs (+ (+ utc tai-diff) shy)))
         (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
         (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))
         )
    (and (time=? utc-basic tai->utc-basic)
         (time=? tai-basic utc->tai-basic)
         (time=? utc-basic-1 tai->utc-basic-1)
         (time=? tai-basic-1 utc->tai-basic-1)
         (time=? utc-basic+1 tai->utc-basic+1)
         (time=? tai-basic+1 utc->tai-basic+1)
         (time=? utc-basic+2 tai->utc-basic+2)
         (time=? tai-basic+2 utc->tai-basic+2)
         )))

(define-s19-test! "TAI-UTC Conversions"
  (lambda ()
    (and
     (test-one-utc-tai-edge 915148800  32 31)
     (test-one-utc-tai-edge 867715200  31 30)
     (test-one-utc-tai-edge 820454400  30 29)
     (test-one-utc-tai-edge 773020800  29 28)
     (test-one-utc-tai-edge 741484800  28 27)
     (test-one-utc-tai-edge 709948800  27 26)
     (test-one-utc-tai-edge 662688000  26 25)
     (test-one-utc-tai-edge 631152000  25 24)
     (test-one-utc-tai-edge 567993600  24 23)
     (test-one-utc-tai-edge 489024000  23 22)
     (test-one-utc-tai-edge 425865600  22 21)
     (test-one-utc-tai-edge 394329600  21 20)
     (test-one-utc-tai-edge 362793600  20 19)
     (test-one-utc-tai-edge 315532800  19 18)
     (test-one-utc-tai-edge 283996800  18 17)
     (test-one-utc-tai-edge 252460800  17 16)
     (test-one-utc-tai-edge 220924800  16 15)
     (test-one-utc-tai-edge 189302400  15 14)
     (test-one-utc-tai-edge 157766400  14 13)
     (test-one-utc-tai-edge 126230400  13 12)
     (test-one-utc-tai-edge 94694400   12 11)
     (test-one-utc-tai-edge 78796800   11 10)
     (test-one-utc-tai-edge 63072000   10 0)
     (test-one-utc-tai-edge 0          0  0) ;; at the epoch
     (test-one-utc-tai-edge 10         0  0) ;; close to it ...
     (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
     )))

(define (tm:date= d1 d2)
  (and (= (date-year d1) (date-year d2))
       (= (date-month d1) (date-month d2))
       (= (date-day d1) (date-day d2))
       (= (date-hour d1) (date-hour d2))
       (= (date-second d1) (date-second d2))
       (= (date-nanosecond d1) (date-nanosecond d2))
       (= (date-zone-offset d1) (date-zone-offset d2))))

(define-s19-test! "TAI-Date Conversions"
  (lambda ()
    (and
     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
               (make-date 0 58 59 23 31 12 1998 0))
     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
               (make-date 0 59 59 23 31 12 1998 0))
     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
               (make-date 0 60 59 23 31 12 1998 0))
     (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
               (make-date 0 0 0 0 1 1 1999 0)))))

(define-s19-test! "Date-UTC Conversions"
  (lambda ()
    (and
     (time=? (make-time time-utc 0 (- 915148800 2))
             (date->time-utc (make-date 0 58 59 23 31 12 1998 0)))
     (time=? (make-time time-utc 0 (- 915148800 1))
             (date->time-utc (make-date 0 59 59 23 31 12 1998 0)))
     ;; yes, I think this is acutally right.
     (time=? (make-time time-utc 0 (- 915148800 0))
             (date->time-utc (make-date 0 60 59 23 31 12 1998 0)))
     (time=? (make-time time-utc 0 (- 915148800 0))
             (date->time-utc (make-date 0 0 0 0 1 1 1999 0)))
     (time=? (make-time time-utc 0 (+ 915148800 1))
             (date->time-utc (make-date 0 1 0 0 1 1 1999 0))))))

(define-s19-test! "TZ Offset conversions"
  (lambda ()
    (let ((ct-utc (make-time time-utc 6320000 1045944859))
          (ct-tai (make-time time-tai 6320000 1045944891))
          (cd (make-date 6320000 19 14 15 22 2 2003 -18000)))
      (and
       (time=? ct-utc (date->time-utc cd))
       (time=? ct-tai (date->time-tai cd))))))

(define-s19-test! "date->string conversions"
  (lambda ()
    (equal? "~.Tue.Tuesday.Jun.June.Tue Jun 05 04:03:02-0200 2007.05.06/05/07. 5,02.000001,Jun.04"
             (date->string (make-date 1000 2 3 4 5 6 2007 -7200)
                                       "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H"))))

(define-s19-test! "string->date conversions"
  (lambda ()
    (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
            (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S"))))

(define-s19-test! "date<->julian-day conversions"
  (lambda ()
   (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
     (and (tm:date= test-date (julian-day->date (date->julian-day test-date) -7200))
          (= 365
             (- (date->julian-day (make-date 0 0 0 0 1 1 2004 0))
                (date->julian-day (make-date 0 0 0 0 1 1 2003 0))))))))

(define-s19-test! "date->modified-julian-day conversions"
  (lambda ()
    (let ([test-date (make-date 0 0 0 0 1 1 2003 -7200)])
      (and (tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200))
           (= 365
              (- (date->modified-julian-day (make-date 0 0 0 0 1 1 2004 0))
                 (date->modified-julian-day (make-date 0 0 0 0 1 1 2003 0))))))))

(define-s19-test! "Time -> Date"
  (lambda ()
    (time->date (current-time))))

(define-s19-test! "date-year-day [2.5 bad argument type for car]"
  (lambda ()
    (= 1 (date-year-day (make-date 0 0 0 0 1 1 2007 0)))))

(define-s19-test! "~1 date->string [2.5 ISO-8601 conversion]"
  (lambda ()
    (equal? "2007-01-01" (date->string (string->date "2007-01-01" "~Y-~m-~d") "~1"))))

(define-s19-test! "milliseconds->time [2.6.1 was using NS/S for conversion!]"
  (lambda ()
    (let ([tim (milliseconds->time 10000)])
      (and (= 10 (time-second tim))
           (= 0 (time-nanosecond tim))))))

(define-s19-test! "Only one minute [2.6.1 current-date w/o tz-locale was doing dst conversion!]"
  (lambda ()
    (let ([lst
            (delete-duplicates
              (fold
                (lambda (n acc)
                  (cons (date-minute (current-date)) acc))
                '()
                ;This number needs to be low enough that the fold completes
                ;in sub-minute time (easy to achieve).
                (iota 2000)))])
      (= 1 (length lst)))))

(define-s19-test! "Conversion"
  (lambda ()

    (define (vector->date1 vec)
      (make-date
        0 0 0 0
        (vector-ref vec 2)
        (vector-ref vec 1)
        (vector-ref vec 0)
        0))

    (define (vector->date2 vec)
      (string->date
        (format "~4,48D~2,48D~2,48DZ" ; ZULU timezone!
                (vector-ref vec 0)
                (vector-ref vec 1)
                (vector-ref vec 2))
        "~Y~m~d~z"))

    (define (to-time obj ->date)
      (cond
        ((time? obj)   obj)
        ((date? obj)   (date->time-utc obj))
        ((vector? obj) (date->time-utc (->date obj)))))

    (define (distance-of-time ->date from to)
      (let* ((from-time (to-time from ->date))
             (to-time (to-time to ->date))
             (diff (time-difference from-time to-time))
             (distance-in-seconds (time-second diff)))
        distance-in-seconds))

    (define vec1 (vector 2006 12 21))
    (define vec2 (vector 2006 12 19))
    (define vec3 (vector 2006 12 20))

    (define tod (current-date))

    (let ([d1-1 (distance-of-time vector->date1 vec1 tod)]
          [d1-2 (distance-of-time vector->date1 vec1 vec2)]
          [d1-3 (distance-of-time vector->date1 vec3 tod)]
          [d2-1 (distance-of-time vector->date2 vec1 tod)]
          [d2-2 (distance-of-time vector->date2 vec1 vec2)]
          [d2-3 (distance-of-time vector->date2 vec3 tod)])
      (and (= d1-1 d2-1) (= d1-2 d2-2) (= d1-3 d2-3)))))

(define-s19-test! "date-week-number"
  (lambda ()
    (and (eqv? 0 (date-week-number (make-date 0 0 0 0 1 1 2007 0) 0))
         (eqv? 51 (date-week-number (make-date 0 0 0 0 27 12 2006 0) 1)))))

(define-s19-test! "date-week-day"
  (lambda ()
    (and (eqv? 1 (date-week-day (make-date 0 0 0 0 1 1 2007 0)))
         (eqv? 3 (date-week-day (make-date 0 0 0 0 27 12 2006 0))))))

(define-s19-test! "2010 leap seconds"
  (lambda ()
    (and (= 1230768032
            (time-second
             (date->time-tai (make-date 0 59 59 23 31 12 2008 0))))
         (= 1230768033
            (time-second
             (date->time-tai (make-date 0 60 59 23 31 12 2008 0))))
         (= 1230768034
            (time-second
             (date->time-tai (make-date 0 0 0 0 1 1 2009 0))))) ) )

;BUG 121
;Need "error" test
#;(format-date #t "~Y")
#;(format-date #t "")
#;(format-date #t "~Y" (make-date 0 2 1 13 10 11 2009 0))
#;(format-date "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H" (make-date 1000 2 3 4 5 6 2007 -7200))

;Duplicate short & long month name keys (`may')
#; ;FIXME Needs method of swapping bundles
(define-s19-test! "Valid month of may"
  (lambda ()
    (with-locale "es_AR.utf8"
      (lambda ()
        (date=? (string->date "16 de Mayo de 2007" "~d de ~B de ~Y")
                (make-date 0 0 0 0 16 5 2007)))) ) )

(define-s19-test! "Date Add Duration"
  (lambda ()
    (let ((dt (make-date 0 59 59 23 31 12 2008 0))
          (dr (make-duration days: 3)) )
      (let ((tdt (date-add-duration dt dr)))
        (date=? tdt (make-date 0 59 59 23 3 1 2009 0)) ) ) ) )

(define-s19-test! "Date Subtract Duration"
  (lambda ()
    (let ((dt (make-date 0 59 59 23 31 12 2008 0))
          (dr (make-duration days: 3)) )
      (let ((tdt (date-subtract-duration dt dr)))
        (date=? tdt (make-date 0 59 59 23 28 12 2008 0)) ) ) ) )

; Duration
; Time Aritmetic (+ - * /)
; Date Comparision
; Date Aritmetic
; Time Period

;;

(begin (newline) (run-s19-tests #t))