;;;; 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
  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
  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
  check-raw-seconds
  check-raw-milliseconds
  check-time-has-type
  check-time-and-type
  check-duration
  check-time-elements check-time-by-elements
  check-times
  check-time-binop
  check-time-compare
  check-time-aritmetic
  check-date-elements check-date-by-elements
  check-date-compatible-timezone-offsets
  error-incompatible-time-types
  error-convert
  error-date-compatible-timezone)

(import scheme
  (chicken base)
  (chicken type)
  (only (chicken string) conc)
  (only locale check-timezone-offset)
  (only type-checks define-check+error-type check-real)
  (only type-errors define-error-type signal-type-error)
  (only srfi-19-timezone check-timezone-name)
  srfi-19-tm)

;;;

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

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

(: check-time (symbol * #!optional (or symbol string) -> time))
(: error-time (symbol * #!optional (or symbol string) -> void))
(: time-type? (* -> boolean : time-type))
(: check-time-type (symbol * #!optional (or symbol string) -> time-type))
(: error-time-type (symbol * #!optional (or symbol string) -> void))
(: time-seconds? (* -> boolean : integer))
(: check-time-seconds (symbol * #!optional (or symbol string) -> integer))
(: error-time-seconds (symbol * #!optional (or symbol string) -> void))
(: time-nanoseconds? (* -> boolean : fixnum))
(: check-time-nanoseconds (symbol * #!optional (or symbol string) -> fixnum))
(: error-time-nanoseconds (symbol * #!optional (or symbol string) -> void))
(: clock-type? (* -> boolean : clock-type))
(: check-clock-type (symbol * #!optional (or symbol string) -> clock-type))
(: error-clock-type (symbol * #!optional (or symbol string) -> void))
(: check-date (symbol * #!optional (or symbol string) -> date))
(: error-date (symbol * #!optional (or symbol string) -> void))
(: date-nanoseconds? (* -> boolean : fixnum))
(: check-date-nanoseconds (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-nanoseconds (symbol * #!optional (or symbol string) -> void))
(: date-seconds? (* -> boolean : fixnum))
(: check-date-seconds (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-seconds (symbol * #!optional (or symbol string) -> void))
(: date-minutes? (* -> boolean : fixnum))
(: check-date-minutes (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-minutes (symbol * #!optional (or symbol string) -> void))
(: date-hours? (* -> boolean : fixnum))
(: check-date-hours (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-hours (symbol * #!optional (or symbol string) -> void))
(: date-day? (* fixnum fixnum -> boolean))
(: check-date-day (symbol * fixnum fixnum -> void))
(: error-date-day (symbol * #!optional (or symbol string) -> void))
(: date-month? (* -> boolean : fixnum))
(: check-date-month (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-month (symbol * #!optional (or symbol string) -> void))
(: date-year? (* -> boolean : fixnum))
(: check-date-year (symbol * #!optional (or symbol string) -> fixnum))
(: error-date-year (symbol * #!optional (or symbol string) -> void))
(: week-day? (* -> boolean : fixnum))
(: check-week-day (symbol * #!optional (or symbol string) -> fixnum))
(: error-week-day (symbol * #!optional (or symbol string) -> void))
(: julian-day? (* -> boolean : real))
(: check-julian-day (symbol * #!optional (or symbol string) -> real))
(: error-julian-day (symbol * #!optional (or symbol string) -> void))
(: check-raw-seconds (symbol * -> real))
(: check-raw-milliseconds (symbol * -> real))
(: check-time-has-type (symbol time time-type -> void))
(: check-time-and-type (symbol time time-type -> void))
(: check-duration (symbol * -> void))
(: check-time-elements (symbol * * * -> void))
(: check-time-by-elements (symbol time -> time))
(: check-times (symbol list -> void))
(: check-time-binop (symbol * * -> void))
(: check-time-compare (symbol * * -> void))
(: check-time-aritmetic (symbol * * -> void))
(: check-date-elements (symbol * * * * * * * * * -> void))
(: check-date-by-elements (symbol date -> date))
(: error-incompatible-time-types (symbol time-type time-type -> void))
(: error-convert (symbol time-type time-type * -> void))
(: error-date-compatible-timezone (symbol date date -> void))
(: check-date-compatible-timezone-offsets (symbol date date -> void))

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

;;; Time Object

;; Time to Date

;;

(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 tm: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 (tm: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)
  (void) )

(define (check-time-by-elements loc tim)
  (check-time-elements loc
    (tm:time-type tim)
    (tm:time-nanosecond tim)
    (tm:time-second tim))
  tim )

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

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

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

;;; Date Object

;;

; 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")
  (void) )

(define (check-date-by-elements loc dat)
  (check-date-elements loc
   (tm:date-nanosecond dat)
   (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
   (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
   (tm:date-zone-offset dat)
   (tm:date-zone-name dat))
  dat )

;;

(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 (= (tm:date-zone-offset dat1) (tm: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 tm:date?)

;; Date TZ information extract

(define (date-timezone-info? obj)
  (tm: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