;;;; srfi-19-support.scm  -*- Scheme -*-
;;;; 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.

;; Issues
;;
;; - Gregorian calendar only.
;;
;; - Initialization is scattered throughout the code, so converting to a module will
;; involve some search.
;;
;; - Some errors have incorrect procedure labels (not the top-level loc)
;;
;; - The Private API but must be visible because of exported syntax

;; Bugs
;;
;; - The 'date-dst?' field is problimatic. It is only valid on certain
;; platforms & only when current. A past or future date will not have this
;; field correct!
;;
;; - Time -> Date conversion takes account of the CURRENT daylight saving time state,
;; NOT the state of the converted date.

;; Notes
;;
;; - There is no year zero. So when converting from a BCE year on the sign of the year
;; needs to be changed, do not subtract one. i.e. 4714 BCE is -4714, not -4713!
;;
;; - Uses ISO 8601 timezone offset interpretation! So an added offset is "away" from
;; UTC & a subtracted offset is "towards" UTC.
;;
;; - Monotonic Time (almost) same as TAI. To redefine Monotonic Time must visit every
;; conversion procedure.

(module srfi-19-support

(;export
  ;;Public
  time? check-time error-time
  time-type? check-time-type error-time-type
  time-seconds? check-time-seconds error-time-seconds
  time-nanoseconds? check-time-nanoseconds error-time-nanoseconds
  clock-type? check-clock-type error-clock-type
  date? check-date error-date
  date-nanoseconds? check-date-nanoseconds error-date-nanoseconds
  date-seconds? check-date-seconds error-date-seconds
  date-minutes? check-date-minutes error-date-minutes
  date-hours? check-date-hours error-date-hours
  date-day? check-date-day error-date-day
  date-month? check-date-month error-date-month
  date-year? check-date-year error-date-year
  week-day? check-week-day error-week-day
  julian-day? check-julian-day error-julian-day
  time-record-printer-format
  date-record-printer-format
  check-raw-seconds
  check-raw-milliseconds
  check-time-has-type
  check-time-and-type
  check-duration
  check-time-elements
  check-times
  check-time-binop
  check-time-compare
  check-time-aritmetic
  check-date-elements
  check-date-compatible-timezone-offsets
  error-incompatible-time-types
  error-convert
  error-date-compatible-timezone)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only srfi-1 fold))
(import (only (chicken io) read-line))
(import (only (chicken read-syntax) define-reader-ctor))
(import (only (chicken gc) current-gc-milliseconds))
(import (only (chicken format) format))
(import (only (chicken time) cpu-time current-seconds current-milliseconds))
(import (only (chicken time posix) seconds->utc-time))
(import (only (chicken string) conc))
(import (only (chicken port) with-input-from-port with-input-from-string))
(import locale)
(import record-variants)
(import type-checks)
(import type-errors)
(import srfi-19-tm)
(import srfi-19-timezone)

;;;

(include "srfi-19-common")

;;;NOTE the use of syntax for inlining is an experiment. no procedure w/
;;;arithmetic can be exported as syntax.

;;; Time Object

(define (time? obj)
  (%time? obj) )

;; Time to Date

;;

(define-constant TIME-FORMAT-SRFI-10 "#,(srfi-19-time ~A ~A ~A)")
(define-constant TIME-FORMAT-BRACKET "#<srfi-19-time ~A ~A ~A>")

(define time-record-printer-format (make-parameter 'SRFI-10
  (lambda (x)
    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
      x
      (begin
        (warning 'time-record-printer-format "invalid format" x)
        (time-record-printer-format) ) ) ) ) )

(define (time-record-printer-format-string)
  (case (time-record-printer-format)
    ((srfi-10 SRFI-10)
      TIME-FORMAT-SRFI-10 )
    (else
      TIME-FORMAT-BRACKET ) ) )

(define-record-printer (srfi-19-time tim out)
  (format out (time-record-printer-format-string)
    (%time-type tim)
    (%time-nanosecond tim)
    (%time-second tim)) )

;SRFI-10
(define-reader-ctor 'srfi-19-time
  (lambda (tt ns sec)
    (%make-time tt ns sec)))

;;

(define (time-type? obj)
  (memq obj '(monotonic utc tai gc duration process thread)) )

(define (time-seconds? obj)
  (integer? obj) )

(define (time-nanoseconds? obj)
  (and (fixnum? obj) (< -NS/S obj NS/S)) )

;;

(define-check+error-type time %time?)
(define-check+error-type time-type)
(define-check+error-type time-seconds)
(define-check+error-type time-nanoseconds)

;; Seconds Conversion

(define (check-raw-seconds loc obj)
  (check-real loc obj 'seconds) )

(define (check-raw-milliseconds loc obj)
  (check-real loc obj 'milliseconds) )

;; Specialized Time Parameter Checking

(define (error-incompatible-time-types loc tt1 tt2)
  (signal-type-error loc "incompatible time-types"  tt1 tt2) )

(define (check-time-has-type loc tim tt)
  (unless (tm:time-has-type? tim tt)
    (error-incompatible-time-types loc (%time-type tim) tt) ) )

(define (check-time-and-type loc tim tt)
  (check-time loc tim)
  (check-time-has-type loc tim tt) )

(define (check-duration loc obj)
  (check-time-and-type loc obj 'duration) )

(define (check-time-elements loc obj1 obj2 obj3)
  (check-time-type loc obj1)
  (check-time-nanoseconds loc obj2)
  (check-time-seconds loc obj3) )

(define (check-times loc objs)
  (for-each (cut check-time loc <>) objs) )

(define (check-time-binop loc obj1 obj2)
  (check-time loc obj1)
  (check-time loc obj2) )

(define (check-time-compare loc obj1 obj2)
  (check-time-binop loc obj1 obj2)
  (check-time-has-type loc obj1 (%time-type obj2)) )

(define (check-time-aritmetic loc tim dur)
  (check-time loc tim)
  (check-duration loc dur) )

;;

(define (date? obj)
  (%date? obj) )

;;

(define-constant DATE-FORMAT-SRFI-10 "#,(srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)")
(define-constant DATE-FORMAT-BRACKET "#<srfi-19-date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A>")

(define date-record-printer-format (make-parameter 'SRFI-10
  (lambda (x)
    (if (or (not x) (eq? 'srfi-10 x) (eq? 'SRFI-10 x))
      x
      (begin
        (warning 'date-record-printer-format "invalid format" x)
        (date-record-printer-format) ) ) ) ) )

(define (date-record-printer-format-string)
  (case (date-record-printer-format)
    ((srfi-10 SRFI-10)
      DATE-FORMAT-SRFI-10 )
    (else
      DATE-FORMAT-BRACKET ) ) )

(define-record-printer (srfi-19-date dat out)
  (format out (date-record-printer-format-string)
   (%date-nanosecond dat)
   (%date-second dat) (%date-minute dat) (%date-hour dat)
   (%date-day dat) (%date-month dat) (%date-year dat)
   (%date-zone-offset dat)
   (%date-zone-name dat) (%date-dst? dat)
   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )

(define-reader-ctor 'srfi-19-date
  (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))

;;

; Nanoseconds in [0 NS/S-1]
(define (date-nanoseconds? obj)
  (and (fixnum? obj) (<= 0 obj) (< obj NS/S)) )

; Seconds in [0 SEC/MIN] ;SEC/MIN legal due to leap second
(define (date-seconds? obj)
  (and (fixnum? obj) (<= 0 obj SEC/MIN)) )

; Minutes in [0 SEC/MIN-1]
(define (date-minutes? obj)
  (and (fixnum? obj) (<= 0 obj) (< obj SEC/MIN)) )

; Hours in [0 HR/DY-1]
(define (date-hours? obj)
  (and (fixnum? obj) (<= 0 obj) (< obj HR/DY)) )

; Days in [1 28/29/30/31] - depending on month & year
(define (date-day? obj mn yr)
  (and (fixnum? obj) (<= 1 obj (tm:days-in-month yr mn))) )

; Months in [1 MN/YR]
(define (date-month? obj)
  (and (fixnum? obj) (<= 1 obj MN/YR)) )

; No year 0!
(define (date-year? obj)
  (and (fixnum? obj) (not (= 0 obj))) )

;;

(define-check+error-type date-nanoseconds)
(define-check+error-type date-seconds)
(define-check+error-type date-minutes)
(define-check+error-type date-hours)
(define-error-type date-day)
(define (check-date-day loc obj mn yr) (unless (date-day? obj mn yr) (error-date-day loc obj)) )
(define-check+error-type date-month)
(define-check+error-type date-year)

(define (check-date-elements loc ns sec min hr dy mn yr tzo tzn)
  (check-date-nanoseconds loc ns)
  (check-date-seconds loc sec)
  (check-date-minutes loc min)
  (check-date-hours loc hr)
  (check-date-year loc yr)
  (check-date-month loc mn)
  (check-date-day loc dy mn yr)
  (check-timezone-offset loc tzo "date-timezone-offset")
  (check-timezone-name loc tzn "date-timezone-name") )

;;

(define (error-date-compatible-timezone loc dat1 dat2)
  (signal-type-error loc "not compatible timezones" dat1 dat2) )

(define (check-date-compatible-timezone-offsets loc dat1 dat2)
  (unless (= (%date-zone-offset dat1) (%date-zone-offset dat2))
    (error-date-compatible-timezone loc dat1 dat2) ) )

;;

(define (clock-type? obj) (memq obj '(monotonic tai utc)))

(define-check+error-type clock-type)

(define (error-convert loc srcnam dstnam obj)
  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )

(define-check+error-type date %date?)

;; Date TZ information extract

(define (date-timezone-info? obj)
  (%date-timezone-info? obj) )

;; Week Day

(define (week-day? obj)
  (and (fixnum? obj) (<= 0 obj 6)) )

(define-check+error-type week-day)

;; Julian-day Operations

(define (julian-day? obj)
  (real? obj) )

(define-check+error-type julian-day)

) ;module srfi-19-support