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

;;Issues
;;
;; - use of check-* im or/and forms is problematic

;; 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? check-date error-date
  date-nanosecond
  date-second
  date-minute
  date-hour
  date-day
  date-month
  date-year
  date-zone-offset
  leap-year?          ;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
  default-date-adjust-integer
  date-zone-name
  date-dst?
  date-copy copy-date
  date->seconds
  date->time
  date-adjust
  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)

(import scheme
  (chicken base)
  (chicken type)
  (only (chicken keyword) string->keyword)
  (only (srfi 1) fold list-index)
  (only (srfi 69)
    make-hash-table symbol-hash hash-table-exists?
    hash-table-ref/default hash-table-set!)
  srfi-8
  (only locale-components check-timezone-components timezone-components?)
  (only miscmacros define-parameter)
  (only type-checks check-string check-integer)
  (only type-errors warning-argument-type)
  (only srfi-19-timezone
    timezone-locale-offset timezone-locale-name timezone-locale-dst?
    checked-optional-timezone-info)
  (only srfi-19-support
    error-convert check-clock-type clock-type? check-date-elements check-date error-date
    check-raw-seconds check-date-compatible-timezone-offsets check-duration
    check-time-and-type check-time check-date-year check-date-month
    check-week-day check-julian-day)
  srfi-19-tm)

;;;

(define (symbol->keyword sym) (string->keyword (symbol->string sym)))

(include-relative "srfi-19-common")

(include-relative "srfi-19-common.types")

(: current-date (#!optional timezone-info -> date))
(: current-julian-day (--> real))
(: current-modified-julian-day (--> real))
(: make-date (real real real real real real real #!optional fixnum string boolean --> date))
(: date? (* -> boolean : date))
(: check-date (symbol * #!optional (or symbol string) -> date))
(: error-date (symbol * #!optional (or symbol string) -> void))
(: date-nanosecond (date --> fixnum))
(: date-second (date --> fixnum))
(: date-minute (date --> fixnum))
(: date-hour (date --> fixnum))
(: date-day (date --> fixnum))
(: date-month (date --> fixnum))
(: date-year (date --> fixnum))
(: date-zone-offset (date --> fixnum))
(: leap-year? ((or date fixnum) --> boolean))
(: date-year-day (date --> fixnum))
(: days-in-month/year (fixnum fixnum --> fixnum))
(: natural-year (fixnum #!optional timezone-info --> fixnum))
(: date-week-day (date --> fixnum))
(: date-week-number (date #!optional fixnum --> fixnum))
(: date->julian-day (date --> real))
(: date->modified-julian-day (date --> real))
(: date->time-monotonic (date --> time))
(: date->time-tai (date --> time))
(: date->time-utc (date --> time))
(: julian-day->date (real #!optional timezone-info --> date))
(: julian-day->time-monotonic (real --> time))
(: julian-day->time-tai (real --> time))
(: julian-day->time-utc (real --> time))
(: modified-julian-day->date (real --> date))
(: modified-julian-day->time-monotonic (real --> time))
(: modified-julian-day->time-tai (real --> time))
(: modified-julian-day->time-utc (real --> time))
(: time-monotonic->date (time --> date))
(: time-monotonic->julian-day (time --> real))
(: time-monotonic->modified-julian-day (time --> real))
(: time-tai->date (time --> date))
(: time-tai->julian-day (time --> real))
(: time-tai->modified-julian-day (time --> real))
(: time-utc->date (time --> date))
(: time-utc->julian-day (time --> real))
(: time-utc->modified-julian-day (time --> real))
(: seconds->date (real --> date))
(: read-leap-second-table (string -> void))
(: time->date (time #!optional timezone-info --> date))
(: default-date-clock-type (#!optional clock-type -> clock-type))
(: default-date-adjust-integer (#!optional (integer -> integer) -> (integer -> integer)))
(: date-zone-name (date --> string))
(: date-dst? (date --> boolean))
(: date-copy (date --> date))
(: date->seconds (date --> real))
(: date->time (date #!optional clock-type --> time))
(: date-adjust (date integer symbol #!optional clock-type --> date))
(: date-difference (date date --> time))
(: date-add-duration (date time #!optional clock-type --> date))
(: date-subtract-duration (date time #!optional clock-type --> date))
(: date=? (date date --> boolean))
(: date>? (date date --> boolean))
(: date<? (date date --> boolean))
(: date>=? (date date --> boolean))
(: date<=? (date date --> boolean))
(: date-max (date #!rest (list-of date) --> date))
(: date-min (date #!rest (list-of date) --> date))
(: time->julian-day (time --> real))
(: time->modified-julian-day (time --> real))
(: date-compare (date date --> fixnum))

;;

;FIXME dup code
;From srfi-19-time
(define (make-duration
          #!key (days 0)
                (hours 0) (minutes 0) (seconds 0)
                (milliseconds 0) (microseconds 0) (nanoseconds 0))
  (let-values (((ns sec)
                  (tm:duration-elements->time-values
                    days hours minutes seconds
                    milliseconds microseconds nanoseconds)))
    (tm:make-time 'duration ns sec) ) )

;;

(define (checked-tm:time->date loc tim tzi)
  ;Note w/ (or ...) error-convert type dominates
  (let ((dat (tm:time->date tim tzi)))
    (unless dat
      (error-convert loc 'time 'date tim))
    dat ) )

;;

(define (checked-tm:date->time loc dat tt)
  ;Note w/ (or ...) error-convert type dominates
  (let ((tim (tm:date->time dat (check-clock-type loc tt))))
    (unless tim
      (error-convert loc 'date 'time dat))
    tim ) )

;;

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

;;; Date Object (Public Immutable)

;;

(define-syntax date-adjuster-create
  (er-macro-transformer
    (lambda (frm r cmp)
      (let ((_date-adjuster-set! (r 'date-adjuster-set!))
            (_begin (r 'begin)) )
        `(,_begin
          ,@(let loop ((args (cdr frm)) (ls '()))
              (if (null? args) ls
                (let ((?key (car args))
                      (?syns (cadr args))
                      (?hdlr (caddr args))
                      (?rest (cdddr args)) )
                  (loop ?rest (cons `(,_date-adjuster-set! ',?key ',?syns ,?hdlr) ls) ) ) ) ) ) ) ) ) )

;;

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

(define-parameter default-date-adjust-integer tm:default-date-adjust-integer
  (lambda (obj)
    (if (procedure? obj) obj
      (begin
        (warning-argument-type 'default-date-adjust-integer obj 'procedure)
        (default-date-adjust-integer) ) ) ) )

;; Date CTOR

(define *unique* (cons #t #f))

(define (make-date ns sec min hr dy mn yr . args)
  (let-optionals args ((tzo (timezone-locale-offset))
                       (tzn #f)
                       (dstf *unique*) )
    (let ((no-dstf (eq? *unique* 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 (date? obj)
  (tm:date? obj) )

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

(: copy-date (deprecated date-copy))
(define copy-date date-copy)

;; 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 #t.

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

(define (date->seconds dat #!optional (tt (default-date-clock-type)))
  (tm:time->seconds
    (tm:date->time
      (check-date 'date->seconds dat)
      (check-clock-type 'date->seconds tt))) )

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

;;

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

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

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

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

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

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

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

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

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

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

;; Date Comparison

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

;;

(define (date-compare dat1 dat2)
  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
    (cond
      ((positive? dif)
        -1)
      ((negative? dif)
        1)
      (else
        0) ) ) )

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

(define (date<? dat1 dat2)
  (positive? (checked-date-compare 'date<? dat1 dat2)) )

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

(define (date>? dat1 dat2)
  (negative? (checked-date-compare 'date>? dat1 dat2)) )

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

(define (date-max dat1 . rest)
  (fold
    (lambda (dat acc)
      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
      (if (positive? (tm:date-compare acc dat)) dat acc) )
    (check-date 'date-max dat1)
    rest) )

(define (date-min dat1 . rest)
  (fold
    (lambda (dat acc)
      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
      (if (negative? (tm:date-compare acc dat)) dat acc) )
    (check-date 'date-min dat1)
    rest) )

;; Date Arithmetic

(define (date-key-order x) (list-index (cut eq? x <>) +date-key-lexical-order+))

(define (date-key-compare a b)
  (if (eq? a b) 0 (- (date-key-order a) (date-key-order b))) )

(define (date-key=? a b) (zero? (date-key-compare a b)))
(define (date-key<? a b) (negative? (date-key-compare a b)))

(define (sort-date-keys keys #!optional (lt date-key<?))
  (import (chicken sort))
  (sort keys lt) )

;date-adjust* date key # ...
;key = year ... nanosecond
(define (date-adjust* dat . adjs)
  (define (adjustments->alist ls)
    ;map kwd amt pair;
    ;kwd->sym sym->key -> (key . amt) ... - resolve synonyms
    '() )
  (define (date-key-alist<? a b)
    (date-key<? (car a) (car b)) )
  (let* ((tt (default-date-clock-type))              ;don't bother w/ arg
         (al (adjustments->alist adjs))              ;(kwds->syms . #) ...
         (al (sort-date-keys al date-key-alist<?)) ) ;smallest unit to largest
    (foldl (lambda (d c) (date-adjust d (cdr c) (car c))) dat al) ) )

(define (date-adjust dat amt key . args)
  (let-optionals args ((tt (default-date-clock-type)))
    (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
      (adjuster
        (check-date 'date-adjust dat)
        ((default-date-adjust-integer) (check-integer 'date-adjust amt))
        key
        ;only used for duration conversion
        tt) ) ) )

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

(define (date-add-duration dat dur . args)
  (check-duration 'date-add-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim
            (checked-tm:date->time 'date-add-duration
              (check-date '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-duration 'date-subtract-duration dur)
  (let-optionals args ((tt (default-date-clock-type)))
    (let ((tim
            (checked-tm:date->time 'date-subtract-duration
              (check-date '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)) ) ) )

;; Date Adjust Handlers

(define (date-adjuster-years dat amt key tt)
  (let ((yr (+ (tm:date-year dat) amt))
        (ndat (tm:copy-date dat)) )
    (tm:date-year-set! ndat yr)
    (when (and (not (tm:leap-year? yr))
               (tm:leap-day? (tm:date-day dat) (tm:date-month dat)))
      (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)))
    ndat ) )

(define (date-adjuster-quarters dat amt key tt)
  (date-adjuster-months dat (* 3 amt) 'months tt) )

(define (date-adjuster-months dat amt key tt)
  (if (zero? amt)
    (tm:copy-date dat)
    (let ((ndat (date-copy dat)))
      (let-values (((yrs mns) (quotient&remainder amt 12)))
        (cond
          ((positive? mns)
            (when (< 12 (+ (tm:date-month dat) mns))
              (tm:date-month-set! ndat 1)
              (set! mns (- mns (- 12 (tm:date-month dat))))
              (set! yrs (+ 1 yrs)) ) )
          (else ;(negative? amt)
            (when (> 1 (+ (tm:date-month dat) mns))
              (tm:date-month-set! ndat 12)
              (set! mns (+ mns (tm:date-month dat)))
              (set! yrs (- yrs 1)) ) ) )
        (tm:date-month-set! ndat (+ mns (tm:date-month ndat)))
        (tm:date-year-set! ndat (+ yrs (tm:date-year ndat)))
        (when (< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
          (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
        ndat  ) ) ) )

(define (date-adjuster-weeks dat amt key tt)
  (date-adjuster-duration dat (* amt 7) 'days tt) )

(define (date-adjuster-duration dat amt key tt)
  (let ((tim (checked-tm:date->time 'date-adjust-duration dat tt))
        (dur (make-duration (symbol->keyword key) amt)) )
    (checked-tm:time->date 'date-adjust-duration
      (tm:add-duration tim dur (tm:as-some-time tim))
      (tm:date-timezone-info dat)) ) )

;; Date Adjust Support

(define +date-adjust-synonym-map+ (make-hash-table eq? symbol-hash))
(define +date-adjuster-map+ (make-hash-table eq? symbol-hash))
(define +date-key-lexical-order+ '())

(define (date-adjust-key? obj)
  (hash-table-exists? +date-adjust-synonym-map+ obj) )

(define (date-adjuster-ref loc key)
  (let ((key (hash-table-ref/default +date-adjust-synonym-map+ key 'UNKNOWN)))
    (values
      key
      (hash-table-ref/default +date-adjuster-map+ key (unknown-date-key-handler loc))) ) )

(define (date-adjuster-set! key syns hdlr)
  ;-set! in ascending order
  (set! +date-key-lexical-order+ (cons key +date-key-lexical-order+))
  ;all are key
  (hash-table-set! +date-adjust-synonym-map+ key key)
  (for-each (cut hash-table-set! +date-adjust-synonym-map+ <> key) syns)
  ;adjuster for key
  (hash-table-set! +date-adjuster-map+ key hdlr) )

(define date-key? date-adjust-key?)

(define ((unknown-date-key-handler loc) dat amt key tt)
  (error loc "unknown date-key" key) )

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

(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)
  (checked-tm:time->date 'time->date
    (check-time 'time->date tim)
    (checked-optional-timezone-info 'time->date (optional tzi #t))) )

;; Date to Time

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

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

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

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

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

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

;; Leap Year

(define (leap-year? dat)
  (tm:leap-year?
    ;assume a number is a year, otherwise extract
    (if (integer? dat)
      dat
      (tm:date-year (check-date 'leap-year? dat)))) )

;; Day of Year

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

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

;; Week Day

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

;;

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

;; Julian-day Operations

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

(define (date->modified-julian-day dat)
  (tm:julian-day->modified-julian-day
    (tm:date->julian-day
      (check-date 'date->modified-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)
  ;Note w/ (or ...) error-convert type dominates
  (let ((jd (tm:time->julian-day (check-time 'time->julian-day tim))))
    (unless jd
      (error-convert 'time->julian-day 'time 'julian-day tim))
    jd ) )

(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)
  ;Note w/ (or ...) error-convert type dominates
  (let ((mjd (tm:time->modified-julian-day (check-time 'time->modified-julian-day tim))))
    (unless mjd
      (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim))
    mjd ) )

;; Julian-day to Time

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

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

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

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

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

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

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

(define (modified-julian-day->date mjdn . tzi)
  (tm:time-utc->date
    (tm:modified-julian-day->time-utc
      (check-julian-day 'modified-julian-day->date 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 Begin

(date-adjuster-create
  years           (year yrs yr y)                  date-adjuster-years
  quarters        (quarter qtrs qtr Q)             date-adjuster-quarters
  months          (month mons mon mns mn M)        date-adjuster-months
  weeks           (week wks wk w)                  date-adjuster-weeks
  days            (day dys dy d)                   date-adjuster-duration
  hours           (hour hrs hr h)                  date-adjuster-duration
  minutes         (minute mins min m)              date-adjuster-duration
  seconds         (second secs sec s)              date-adjuster-duration
  milliseconds    (millisecond millis milli ms)    date-adjuster-duration
  microseconds    (microsecond micros micro us)    date-adjuster-duration
  nanoseconds     (nanosecond nanos nano ns)       date-adjuster-duration)

) ;module srfi-19-date