;;;; srfi-19-test.scm  -*- Scheme -*-

(import test)

(include-relative "test-gloss.incl")

;;;

(test-begin "SRFI 19")

(import srfi-19)

;;;

(import (srfi 1))   ;For current-date w/o tz-locale test
(import format)     ;For conversion test

;;

#| ;Unused
(import locale)
(define (with-locale lcl thunk)
  (let (
    (cur (current-locale)) )
    (dynamic-wind
      (lambda () (current-locale lcl))
      thunk
      (lambda () (current-locale cur))) ) )
|#

;;

(test-assert "Creating time (current-time time-tai)" (current-time time-tai))
(test-assert "Creating time (current-time time-utc)" (current-time time-utc))
(test-assert "Creating time (current-time time-monotonic)" (current-time time-monotonic))
(test-assert "Creating time (current-time time-thread)" (current-time time-thread))
(test-assert "Creating time (current-time time-process)" (current-time time-process))

(test-assert "Testing time (time-resolution time-tai)" (time-resolution time-tai))
(test-assert "Testing time (time-resolution time-utc)" (time-resolution time-utc))
(test-assert "Testing time (time-resolution time-monotonic)" (time-resolution time-monotonic))
(test-assert "Testing time (time-resolution time-thread)" (time-resolution time-thread))
(test-assert "Testing time (time-resolution time-process)" (time-resolution time-process))

(test-assert "Time nanos positive"
  (and-let* (
    (ct (current-time))
    ((time? ct)) )
    (not (negative? (time-nanosecond ct)))))

(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)))
  (test-assert "Time comparison (time=? t1 t2)" (time=? t1 t2))
  (test-assert "Time comparison (time>? t3 t2)" (time>? t3 t2))
  (test-assert "Time comparison (time<? t2 t3)" (time<? t2 t3))
  (test-assert "Time comparison (time>=? t1 t2)" (time>=? t1 t2))
  (test-assert "Time comparison (time>=? t3 t2)" (time>=? t3 t2))
  (test-assert "Time comparison (time<=? t1 t2)" (time<=? t1 t2))
  (test-assert "Time comparison (time<=? t2 t3)" (time<=? t2 t3))
  (test-assert "Time comparison (time=? t11 t12)" (time=? t11 t12))
  (test-assert "Time comparison (time>? t13 t12)" (time>? t13 t12))
  (test-assert "Time comparison (time<? t12 t13)" (time<? t12 t13))
  (test-assert "Time comparison (time>=? t11 t12)" (time>=? t11 t12))
  (test-assert "Time comparison (time>=? t13 t12)" (time>=? t13 t12))
  (test-assert "Time comparison (time<=? t11 t12)" (time<=? t11 t12))
  (test-assert "Time comparison (time<=? t12 t13)" (time<=? t12 t13)) )

(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)))
  (test-assert "Time difference 1" (time=? t3 (time-difference t1 t2)))
  (test-assert "Time difference 2" (time=? t4 (time-difference t2 t1))) )

(define test-one-utc-tai-edge
  (let (
    (+cnt+ 0) )
    (define (idmsg)
      (set! +cnt+ (add1 +cnt+))
      (string-append "TAI-UTC Conversions" " " (number->string +cnt+)) )
    (lambda (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)) )
        (test-assert (idmsg) (time=? utc-basic tai->utc-basic))
        (test-assert (idmsg) (time=? tai-basic utc->tai-basic))
        (test-assert (idmsg) (time=? utc-basic-1 tai->utc-basic-1))
        (test-assert (idmsg) (time=? tai-basic-1 utc->tai-basic-1))
        (test-assert (idmsg) (time=? utc-basic+1 tai->utc-basic+1))
        (test-assert (idmsg) (time=? tai-basic+1 utc->tai-basic+1))
        (test-assert (idmsg) (time=? utc-basic+2 tai->utc-basic+2))
        (test-assert (idmsg) (time=? tai-basic+2 utc->tai-basic+2)) ) ) ) )

(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 test-one-tai-date-edge
  (let (
    (+cnt+ 0) )
    (define (idmsg)
      (set! +cnt+ (add1 +cnt+))
      (string-append "TAI-Date Conversions" " " (number->string +cnt+)) )
    (lambda (tai-diff dat)
      (let* (
        (tai (make-time time-tai 0 (+ 915148800 tai-diff)))
        (tai-dat (time-tai->date tai 0)) )
        #;(glossf "tai-dat: ~S | dat: ~S" (date->string tai-dat) (date->string dat))
        (test-assert (idmsg) (tm:date= tai-dat dat)) ) ) ) )

(test-one-tai-date-edge 29 (make-date 0 58 59 23 31 12 1998 0))
(test-one-tai-date-edge 30 (make-date 0 59 59 23 31 12 1998 0))
(test-one-tai-date-edge 31 (make-date 0 60 59 23 31 12 1998 0))
(test-one-tai-date-edge 32 (make-date 0 0 0 0 1 1 1999 0))

(test-assert "Date-UTC Conversions"
  (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)))))

(test-assert "TZ Offset conversions"
  (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)))))

(test-assert "date->string conversions"
  (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")))

(test-assert "local-timezone-locale"
  (local-timezone-locale))

(test-assert "string->date conversions"
  (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")))

(test-assert "date<->julian-day conversions"
  (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)))))))

(test-assert "date->modified-julian-day conversions"
  (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)))))))

(test-assert "Time -> Date"
  (time->date (current-time)))

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

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

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

(test-assert "Only one minute [2.6.1 current-date w/o tz-locale doing dst conv!]"
  (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))))

(let ()

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

  (test-assert "Conversion"
    (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)))) )

(test-assert "date-week-number"
  (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))))

(test-assert "date-week-day"
  (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)))))

(test-assert "2010 leap seconds"
  (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 "")

;(glossf "dat: ~S" (format-date #t "~Y" (make-date 0 2 1 13 10 11 2009 0)))
;(glossf "dat: ~S" (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 i18n bundles
(test-assert "Valid month of may"
  (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)))))

(test-assert "Date Add Duration"
  (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)))))

(test-assert "Date Subtract Duration"
  (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)))))

(test-assert "#966 does not recognise the first item in abbrev vectors for any lang"
  (and
    (date=?
      (scan-date "Mon, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
      (make-date 0 9 46 3 12 1 2014 3600))
    (date=?
      (scan-date "Sun, 12 Jan 2014 03:46:09 +0100" "~a, ~d ~b ~Y ~H:~M:~S ~z")
      (make-date 0 9 46 3 12 1 2014 3600))))

(test-assert "date-adjust-last-day"
  (let (
    (jan31 (make-date 0 0 0 0 31 1 2010 3600))
    (feb28 (make-date 0 0 0 0 28 2 2010 3600)) )
    (date=?
      feb28
      (date-adjust jan31 1 'months))))

(test-assert "date-adjust-dst-dys-fixed"
  (let (
    (m (make-date 0 0 0 5 12 3 2011)))
    (= (date-hour m) (date-hour (date-adjust m 1 'days)))))

(test-assert "date-adjust-dst-dys-day"
  (let (
    (m (make-date 0 0 0 5 12 3 2011)))
    (= (+ 1 (date-day m)) (date-day (date-adjust m 1 'days)))))

(test-assert "date-adjust-dst-hrs-fixed"
  (let (
    (m (make-date 0 0 0 5 12 3 2011)))
    (= (date-hour m) (date-hour (date-adjust m 24 'hours)))))

(test-assert "date-adjust-dst-hrs-day"
  (let (
    (m (make-date 0 0 0 5 12 3 2011)))
    (= (+ 1 (date-day m)) (date-day (date-adjust m 24 'hours)))))

;NOTE MomentJS says:
;
;If you are adding hours, minutes, seconds, or milliseconds, the
;assumption is that you want precision to the hour, and will result in a
;different hour.
;
;but if 1 day = 24 hours then the above is nonsense.

#;
(test-assert "date-adjust-dst-hrs"
  (let (
    (m (make-date 0 0 0 5 12 3 2011)))
    (= (+ 1 (date-hour m)) (date-hour (date-adjust m 24 'hours)))))

;BUG #1000
(test-assert "srfi-18-time-works"
  (let (
    (m (make-date 0 0 0 0 21 3 2013)))
    (let (
      (tim (date->time m)))
      (time=?
        tim
        (add-duration
          (zero-time 'utc')
          (srfi-18-time->time (time->srfi-18-time tim)))))))

(test-assert "seconds 0 <-> date"
  (= 0 (date->seconds (seconds->date 0))))

;reported by tokyo_jesus on #chicken irc
(test-assert "(seconds->date 250.0) failed due to flonum seconds->utc-time argument"
  (seconds->date 250.0))

(test-assert "(seconds->date 250) failed"
  (seconds->date 250))

(test-assert "(current-date) failed"
  (current-date))

(test-assert "-TZ Format"
  (equal?
    "2020-03-16T18:28:16-0700"
    (date->string
      (make-date 0 16 28 18 16 3 2020 -25200)
      "~Y-~m-~dT~H:~M:~S~z")))

(test-assert "+TZ Format"
  (equal?
    "2020-03-16T18:28:16+0700"
    (date->string
      (make-date 0 16 28 18 16 3 2020 25200)
      "~Y-~m-~dT~H:~M:~S~z")))

;
(test-assert "time-utc->date failed"
  (time-utc->date (date->time-utc (make-date 0 0 0 0 1 1 1970 0))))

;; Literals

(import (only (chicken port) with-input-from-string))
(import srfi-19-literals)

(test-assert "Read Literal"
  (equal?
    '(make-date 0 16 28 18 16 3 2020 -25200)
    (with-input-from-string "2020-03-16T18:28:16-0700" read-date-literal)))

;; Time Period

(import srfi-19-period)

(let ((dt (current-date))
      (tm (begin (sleep 1) (current-time))) )
  (let (
    (tpdt (make-time-period dt dt))
    (tptm (make-time-period tm tm)) )
    (test-assert "same date time-period" (time-period? tpdt))
    (test-assert "same time time-period" (time-period? tptm))
    (test-assert "same date time-period null" (time-period-null? tpdt))
    (test-assert "same time time-period null" (time-period-null? tptm))
    ;(glossf "tp date: ~S" tpdt)
    ;(glossf "tp time: ~S" tptm)
    (test-assert "date precedes time" (time-period-precedes? tpdt tptm))
    (test-assert "time preceded-by date" (time-period-preceded-by? tptm tpdt))
    (test-assert "date <= time" (time-period<=? tpdt tptm))
    (test-assert "time >= date" (time-period>=? tptm tpdt))
    (test-assert "time-period date precedes time" (time-period-preceding tpdt tptm))
    ;(glossf "tp preceding: ~S" (time-period-preceding tpdt tptm))
    (test-assert "time-period date not succeeds time" (not (time-period-succeeding tpdt tptm)))
    (test-assert "time-period time succeeds date" (time-period-succeeding tptm tpdt))
    ;(glossf "tp succeeding: ~S" (time-period-succeeding tptm tpdt))
    (test-assert "time-period copy" (time-period=? tpdt (time-period-copy tpdt)))
    ;(glossf "time-period copy: ~S" (time-period-copy tpdt))
    (test-assert (eq? time-utc (time-period-type tpdt)))
    (test-assert (zero? (time-compare (time-period-begin tpdt) (time-period-end tpdt))))
    (test-assert "time-period last 1ns diff"
      (= 1 (- (time->nanoseconds (time-period-end tpdt))
              (time->nanoseconds (time-period-last tpdt)))))
    ;(glossf "tp last: ~S" (time-period-last tpdt))
    (test-assert (time-zero? (time-period-duration tpdt)))
    ;(glossf "tp duration: ~S" (time-period-duration tpdt))
    ) )

;; TBD

; Duration
; Time Aritmetic (+ - * /)
; Date Comparision
; Date Aritmetic
; Period ctors, properties, relations, operations, clock-type alignment

;;;

(test-end "SRFI 19")

(test-exit)