;;;; srfi-19-date.scm
;;;; Chicken port, Kon Lovett, Dec '05

;; SRFI-19: Time Data Types and Procedures.
;;
;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
;;
;; This document and translations of it may be copied and furnished to others,
;; and derivative works that comment on or otherwise explain it or assist in its
;; implementation may be prepared, copied, published and distributed, in whole or
;; in part, without restriction of any kind, provided that the above copyright
;; notice and this paragraph are included on all such copies and derivative works.
;; However, this document itself may not be modified in any way, such as by
;; removing the copyright notice or references to the Scheme Request For
;; Implementation process or editors, except as needed for the purpose of
;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
;; process must be followed, or as required to translate it into languages other
;; than English.
;;
;; The limited permissions granted above are perpetual and will not be revoked
;; by the authors or their successors or assigns.
;;
;; This document and the information contained herein is provided on an "AS IS"
;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.

(module srfi-19-date

  (;export
    ; SRFI-19
    current-date
    current-julian-day
    current-modified-julian-day
    make-date
    date-nanosecond
    date-second
    date-minute
    date-hour
    date-day
    date-month
    date-year
    date-zone-offset
    leap-year? ; Actually part of SRFI 19 but not in original document
    date-year-day
    days-in-month/year
    natural-year
    date-week-day
    date-week-number
    date->julian-day
    date->modified-julian-day
    date->time-monotonic
    date->time-tai
    date->time-utc
    julian-day->date
    julian-day->time-monotonic
    julian-day->time-tai
    julian-day->time-utc
    modified-julian-day->date
    modified-julian-day->time-monotonic
    modified-julian-day->time-tai
    modified-julian-day->time-utc
    time-monotonic->date
    time-monotonic->julian-day
    time-monotonic->modified-julian-day
    time-tai->date
    time-tai->julian-day
    time-tai->modified-julian-day
    time-utc->date
    time-utc->julian-day
    time-utc->modified-julian-day
    ; Extensions
    seconds->date
    read-leap-second-table
    time->date
    default-date-clock-type
    date-zone-name
    date-dst?
    copy-date
    date->time
    date-difference
    date-add-duration
    date-subtract-duration
    date=?
    date>?
    date<?
    date>=?
    date<=?
    date-max
    date-min
    time->julian-day
    time->modified-julian-day
    date-compare
    ; DEPRECATED
    seconds->date/type)

  (import
    (except scheme
      zero? negative? positive? real?)
    chicken
    #;srfi-8
    (only numbers
      zero? negative? positive? real?)
    miscmacros
    (only locale-components
      check-timezone-components timezone-components?)
    type-checks
    type-errors
    srfi-19-timezone
    srfi-19-support)

  (require-library
    #;srfi-8
    numbers miscmacros locale-components
   type-checks type-errors
   srfi-19-timezone srfi-19-support)

;;;

;;

(define (checked-tm:time->date loc tim tzi)
  (or (tm:time->date tim tzi)
      (error-convert loc 'time 'date tim)) )

;;

(define (checked-tm:date->time loc dat tt)
  (check-clock-type loc tt)
  (or (tm:date->time dat tt)
      (error-convert loc 'date 'time dat)) )

;;

(define (read-leap-second-table flnm)
  (check-string 'read-leap-second-table flnm) ;FIXME should be check-pathname
  (tm:read-leap-second-table flnm) )

;;; Date Object (Public Immutable)

;;

;FIXME should this be thread-specific?
(define-parameter default-date-clock-type 'utc
  (lambda (obj)
    (cond
      ((clock-type? obj) obj)
      (else
        (warning-argument-type 'default-date-clock-type obj 'clock-type)
        (default-date-clock-type) ) ) ) )

;; Date CTOR

(define (make-date ns sec min hr dy mn yr . args)
  (let-optionals args ((tzo (timezone-locale-offset)) (tzn #f) (dstf (void)))
    (let ((no-dstf (eq? (void) dstf)))
      (cond
        ((timezone-components? tzo)
          ; Supplied parameters override
          (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
          (set! tzn (or tzn (timezone-locale-name tzo)))
          (set! tzo (timezone-locale-offset tzo)) )
        (else
          (when no-dstf (set! dstf #f)) ) ) )
    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )

(define (copy-date dat)
  (check-date 'copy-date dat)
  (tm:copy-date dat) )

;; Converts a seconds value, may be fractional, into a date type.
;; The seconds value is number of seconds since 00:00:00 January 1, 1970.
;; A local (#t), utc (#f), or other (timezone-components) date depending on
;; the optional 2nd argument. The default is #f.

(define (seconds->date sec . tzi)
  (check-raw-seconds 'seconds->date sec)
  (let ((tzc (checked-optional-timezone-info 'seconds->date (optional tzi #t))))
    (check-timezone-components 'seconds->date tzc)
    (tm:seconds->date/type sec tzc) ) )

(define seconds->date/type seconds->date) ; DEPRECATED

(define (current-date . tzi)
  (tm:current-date (checked-optional-timezone-info 'current-date (optional tzi #t))) )

;;

(define (date-nanosecond dat)
	(check-date 'date-nanosecond dat)
	(tm:date-nanosecond dat) )

(define (date-second dat)
	(check-date 'date-second dat)
	(tm:date-second dat) )

(define (date-minute dat)
	(check-date 'date-minute dat)
	(tm:date-minute dat) )

(define (date-hour dat)
	(check-date 'date-hour dat)
	(tm:date-hour dat) )

(define (date-day dat)
	(check-date 'date-day dat)
	(tm:date-day dat) )

(define (date-month dat)
	(check-date 'date-month dat)
	(tm:date-month dat) )

(define (date-year dat)
	(check-date 'date-year dat)
	(tm:date-year dat) )

(define (date-dst? dat)
	(check-date 'date-dst? dat)
	(tm:date-dst? dat) )

(define (date-zone-offset dat)
	(check-date 'date-zone-offset dat)
	(tm:date-zone-offset dat) )

(define (date-zone-name dat)
	(check-date 'date-zone-name dat)
	(tm:date-zone-name dat) )

;; Date Comparison

(define (checked-date-compare loc dat1 dat2)
  (check-date loc dat1)
  (check-date loc dat2)
  (check-date-compatible-timezone-offsets loc dat1 dat2)
  (tm:date-compare dat1 dat2) )

;;

(define (date-compare dat1 dat2)
  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
    (cond ((fx> 0 dif)  -1)
          ((fx< 0 dif)  1)
          (else         0) ) ) )

(define (date=? dat1 dat2)
  (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )

(define (date<? dat1 dat2)
  (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )

(define (date<=? dat1 dat2)
  (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )

(define (date>? dat1 dat2)
  (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )

(define (date>=? dat1 dat2)
  (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )

(define (date-max dat1 . rest)
  (check-date 'date-max dat1)
  (let loop ((acc dat1) (ls rest))
    (if (null? ls) acc
        (let ((dat (car ls)))
          (check-date 'date-max dat)
          (check-date-compatible-timezone-offsets 'date-max acc dat)
          (loop (if (fx> 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )

(define (date-min dat1 . rest)
  (check-date 'date-min dat1)
  (let loop ((acc dat1) (ls rest))
    (if (null? ls) acc
        (let ((dat (car ls)))
          (check-date 'date-min dat)
          (check-date-compatible-timezone-offsets 'date-min acc dat)
          (loop (if (fx< 0 (tm:date-compare acc dat)) dat acc) (cdr ls)) ) ) ) )

;; Date Arithmetic

(define (date-difference dat1 dat2 . args)
  (check-date 'date-difference dat1)
  (check-date 'date-difference dat2)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim1 (checked-tm:date->time 'date-difference dat1 tt))
          (tim2 (checked-tm:date->time 'date-difference dat2 tt)) )
      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )

(define (date-add-duration dat dur . args)
  (check-date 'date-add-duration dat)
  (check-duration 'date-add-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim (checked-tm:date->time 'date-add-duration dat tt)) )
      (checked-tm:time->date 'date-add-duration
        (tm:add-duration tim dur (tm:as-some-time tim))
        (tm:date-timezone-info dat)) ) ) )

(define (date-subtract-duration dat dur . args)
  (check-date 'date-subtract-duration dat)
  (check-duration 'date-subtract-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim (checked-tm:date->time 'date-subtract-duration dat tt)) )
      (checked-tm:time->date 'date-subtract-duration
        (tm:subtract-duration tim dur (tm:as-some-time tim))
        (tm:date-timezone-info dat)) ) ) )

;; Time to Date

(define (time-tai->date tim . tzi)
  (check-time-and-type 'time-tai->date tim 'tai)
  (tm:time-tai->date tim (checked-optional-timezone-info 'time-tai->date (optional tzi #t))) )

(define (time-utc->date tim . tzi)
  (check-time-and-type 'time-utc->date tim 'utc)
  (tm:time-utc->date tim (checked-optional-timezone-info 'time-utc->date (optional tzi #t))) )

(define (time-monotonic->date tim . tzi)
  (check-time-and-type 'time-monotonic->date tim 'monotonic)
  (tm:time-utc->date tim (checked-optional-timezone-info 'time-monotonic->date (optional tzi #t))) )

(define (time->date tim . tzi)
  (check-time 'time->date tim)
  (checked-tm:time->date 'time->date
    tim
    (checked-optional-timezone-info 'time->date (optional tzi #t))) )

;; Date to Time

(define (date->time-utc dat)
  (check-date 'date->time-utc dat)
  (tm:date->time-utc dat) )

(define (date->time-tai dat)
  (check-date 'date->time-tai dat)
  (tm:date->time-tai dat) )

(define (date->time-monotonic dat)
  (check-date 'date->time-monotonic dat)
  (tm:date->time-monotonic dat) )

(define (date->time dat . args)
  (check-date 'date->time dat)
  (let-optionals args ((tt (default-date-clock-type)))
    (checked-tm:date->time 'date->time dat tt) ) )

;; Given a 'two digit' number, find the year within 50 years +/-

(define (natural-year n . tzi)
  (check-date-year 'natural-year n)
  (tm:natural-year n (checked-optional-timezone-info 'natural-year (optional tzi #t))) )

;; Leap Year

(define (leap-year? dat)
  (tm:leap-year?
    (if (fixnum? dat) dat
      (tm:date-year (check-date 'date-leap-year? dat)))) )

;; Day of Year

(define (date-year-day dat)
  (check-date 'date-year-day dat)
  (tm:date-year-day dat) )

(define (days-in-month/year mn yr)
  (check-date-year 'days-in-month/year yr)
  (check-date-month 'days-in-month/year mn)
  (tm:days-in-month yr mn) )

;; Week Day

(define (date-week-day dat)
  (check-date 'date-week-day dat)
  (tm:date-week-day dat) )

;;

(define (date-week-number dat . args)
  (check-date 'date-week-number dat)
  (let-optionals args ((1st-weekday 0))
    (check-week-day 'date-week-number 1st-weekday)
    (tm:date-week-number dat 1st-weekday) ) )

;; Julian-day Operations

(define (date->julian-day dat)
  (check-date 'date->julian-day dat)
  (tm:date->julian-day dat) )

(define (date->modified-julian-day dat)
  (check-date 'date->modified-julian-day dat)
  (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )

;; Time to Julian-day

(define (time-utc->julian-day tim)
  (check-time-and-type 'time-utc->julian-day tim 'utc)
  (tm:time-utc->julian-day tim) )

(define (time-tai->julian-day tim)
  (check-time-and-type 'time-tai->julian-day tim 'tai)
  (tm:time-tai->julian-day tim) )

(define (time-monotonic->julian-day tim)
  (check-time-and-type 'time-monotonic->julian-day tim 'monotonic)
  (tm:time-monotonic->julian-day tim) )

(define (time->julian-day tim)
  (check-time 'time->julian-day tim)
  (or (tm:time->julian-day tim)
      (error-convert 'time->julian-day 'time 'julian-day tim) ) )

(define (time-utc->modified-julian-day tim)
  (check-time-and-type 'time-utc->modified-julian-day tim 'utc)
  (tm:time-utc->modified-julian-day tim) )

(define (time-tai->modified-julian-day tim)
  (check-time-and-type 'time-tai->modified-julian-day tim 'tai)
  (tm:time-tai->modified-julian-day tim) )

(define (time-monotonic->modified-julian-day tim)
  (check-time-and-type 'time-monotonic->modified-julian-day tim 'monotonic)
  (tm:time-monotonic->modified-julian-day tim) )

(define (time->modified-julian-day tim)
  (check-time 'time->modified-julian-day tim)
  (or (tm:time->modified-julian-day tim)
      (error-convert 'time->modified-julian-day 'time 'modified-julian-day  tim) ) )

;; Julian-day to Time

(define (julian-day->time-utc jdn)
  (check-julian-day 'julian-day->time-utc jdn)
  (tm:julian-day->time-utc jdn) )

(define (julian-day->time-tai jdn)
  (check-julian-day 'julian-day->time-tai jdn)
  (let ((tim (tm:julian-day->time-utc jdn)))
    (tm:time-utc->time-tai tim tim) ) )

(define (julian-day->time-monotonic jdn)
  (check-julian-day 'julian-day->time-monotonic jdn)
  (let ((tim (julian-day->time-utc jdn)))
    (tm:time-utc->time-monotonic tim tim) ) )

(define (julian-day->date jdn . tzi)
  (check-julian-day 'julian-day->date jdn)
  (tm:time-utc->date (tm:julian-day->time-utc jdn)
                     (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )

(define (modified-julian-day->time-utc mjdn)
  (check-julian-day 'modified-julian-day->time-utc mjdn)
  (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )

(define (modified-julian-day->time-tai mjdn)
  (check-julian-day 'modified-julian-day->time-tai mjdn)
  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
    (tm:time-utc->time-tai tim tim) ) )

(define (modified-julian-day->time-monotonic mjdn)
  (check-julian-day 'modified-julian-day->time-monotonic mjdn)
  (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
    (tm:time-utc->time-monotonic tim tim) ) )

(define (modified-julian-day->date mjdn . tzi)
  (check-julian-day 'modified-julian-day->date mjdn)
  (tm:time-utc->date (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
                     (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )

;; The Julian-day

(define (current-julian-day)
  (tm:time-utc->julian-day (tm:current-time-utc)) )

(define (current-modified-julian-day)
  (tm:time-utc->modified-julian-day (tm:current-time-utc)) )

) ;module srfi-19-date