;;;; srfi-19-time.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.

(module srfi-19-time

(;export
  ;;SRFI-19
  time-tai
  time-utc
  time-monotonic
  time-thread
  time-process
  time-duration
  time-gc
  current-time
  time-resolution
  make-time
  time-type
  time-nanosecond
  time-second
  set-time-type!
  set-time-nanosecond!
  set-time-second!
  copy-time
  time<=?
  time<?
  time=?
  time>=?
  time>?
  time-difference
  time-difference!
  add-duration
  add-duration!
  subtract-duration
  subtract-duration!
  time-monotonic->time-tai
  time-monotonic->time-tai!
  time-monotonic->time-utc
  time-monotonic->time-utc!
  time-tai->time-monotonic
  time-tai->time-monotonic!
  time-tai->time-utc
  time-tai->time-utc!
  time-utc->time-monotonic
  time-utc->time-monotonic!
  time-utc->time-tai
  time-utc->time-tai!
  ;;Extensions
  time-record-printer-format
  one-second-duration
  one-nanosecond-duration
  zero-time
  make-duration
  divide-duration
  divide-duration!
  multiply-duration
  multiply-duration!
  time->srfi-18-time
  srfi-18-time->time
  time-max
  time-min
  time-negative?
  time-positive?
  time-zero?
  time-abs
  time-abs!
  time-negate
  time-negate!
  seconds->time
  nanoseconds->time
  nanoseconds->seconds
  milliseconds->time
  milliseconds->seconds
  time->nanoseconds
  time->milliseconds
  time->seconds
  time-compare)

(import scheme)
(import (chicken base))
(import (prefix (only srfi-18 seconds->time time->seconds) srfi-18:))
#;(import srfi-8)
(import miscmacros)
(import type-checks)
(import type-errors)
(import srfi-19-tm)
(import srfi-19-support)

;;;

;; Time Type Constants (not used internally)

(define time-duration   'duration)
(define time-gc         'gc)
(define time-monotonic  'monotonic)
(define time-process    'process)
(define time-tai        'tai)
(define time-thread     'thread)
(define time-utc        'utc)

;; Time CTORs

(define (one-second-duration) (tm:make-time 'duration 0 1))
(define (one-nanosecond-duration) (tm:make-time 'duration 1 0))
(define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0))

(define (make-time tt ns sec)
  (check-time-elements 'make-time tt ns sec)
  (tm:make-time tt ns sec) )

(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
        (check-real 'make-duration days 'days)
        (check-real 'make-duration hours 'hours)
        (check-real 'make-duration minutes 'minutes)
        (check-real 'make-duration seconds 'seconds)
        (check-real 'make-duration milliseconds 'milliseconds)
        (check-real 'make-duration microseconds 'microseconds)
        (check-real 'make-duration nanoseconds 'nanoseconds))) )
    (check-time-elements 'make-duration 'duration ns sec)
    (tm:make-time 'duration ns sec) ) )

(define (copy-time tim)
  (tm:copy-time (check-time 'copy-time tim)) )

;; Time record-type operations

(define (time-type tim)
  (tm:time-type (check-time 'time-type tim)) )

(define (time-nanosecond tim)
  (tm:time-nanosecond (check-time 'time-nanosecond tim)) )

(define (time-second tim)
  (tm:time-second (check-time 'time-second tim)) )

(define (set-time-type! tim tt)
  (tm:time-type-set!
    (check-time 'set-time-type! tim)
    (check-time-type 'set-time-type! tt)) )

(define (set-time-nanosecond! tim ns)
  (tm:time-nanosecond-set!
    (check-time 'set-time-nanosecond! tim)
    (check-time-nanoseconds 'set-time-nanosecond! ns)) )

(define (set-time-second! tim sec)
  (tm:time-second-set!
    (check-time 'set-time-second! tim)
    (check-time-seconds 'set-time-second! sec)) )

;; Seconds Conversion

(define (nanoseconds->time ns . args)
  (let-optionals args ((tt 'duration))
    (let-values (
      ((ns sec) (tm:nanoseconds->time-values ns)) )
      (check-time-elements 'nanoseconds->time tt ns sec)
      (tm:make-time tt ns sec) ) ) )

(define (nanoseconds->seconds ns)
  (tm:nanoseconds->seconds (check-real 'nanoseconds->seconds ns)) )

(define (milliseconds->time ms . args)
  (let-optionals args ((tt 'duration))
    (let-values (
      ((ns sec)
        (tm:milliseconds->time-values
          (check-raw-milliseconds 'milliseconds->time ms))) )
      (check-time-elements 'milliseconds->time tt ns sec)
      (tm:make-time tt ns sec) ) ) )

(define (milliseconds->seconds ms)
  (tm:milliseconds->seconds
    (check-raw-milliseconds 'milliseconds->seconds ms)) )

;; Converts a seconds value, may be fractional, into a time type.
;; The type of time default is time-duration.

(define (seconds->time sec . args)
  (let-optionals args ((tt 'duration))
    (tm:seconds->time
      (check-raw-seconds 'seconds->time sec)
      (check-time-type 'seconds->time tt)) ) )

(define (time->nanoseconds tim)
  (tm:time->nanoseconds (check-time 'time->nanoseconds tim)) )

(define (time->milliseconds tim)
  (tm:time->milliseconds (check-time 'time->milliseconds tim)) )

(define (time->seconds tim)
  (tm:time->seconds (check-time 'time->seconds tim)) )

;; Current time routines

(define (current-time . args)
  (let-optionals args ((tt 'utc))
    (case tt
      ((monotonic) (tm:current-time-monotonic))
      ((utc)       (tm:current-time-utc))
      ((tai)       (tm:current-time-tai))
      ((gc)        (tm:current-time-gc))
      ((process)   (tm:current-time-process))
      ((thread)    (tm:current-time-thread))
      (else
        (error-time-type 'current-time tt)) ) ) )

;; -- Time Resolution
;; This is the resolution of the clock in nanoseconds.
;; This will be implementation specific.

(define (time-resolution . args)
  (let-optionals args ((tt 'utc))
    (tm:time-resolution (check-time-type 'time-resolution tt)) ) )

;; SRFI-18 Routines

(define (srfi-18-time->time srfi-18-tim)
  (tm:seconds->time
    (srfi-18:time->seconds srfi-18-tim)
    'duration) )

(define (time->srfi-18-time tim)
  (srfi-18:seconds->time
    (exact->inexact
      (tm:time->seconds (check-time 'time->srfi-18-time tim)))) )

;; Time Comparison

(define (time-compare tim1 tim2)
  (check-time-compare 'time-compare tim1 tim2)
  (let ((dif (tm:time-compare tim1 tim2)))
    (cond
      ((negative? dif)  -1)
      ((positive? dif)  1)
      (else             0) ) ) )

(define (time=? tim1 tim2)
  (check-time-compare 'time=? tim1 tim2)
  (tm:time=? tim1 tim2) )

(define (time>? tim1 tim2)
  (check-time-compare 'time>? tim1 tim2)
  (tm:time>? tim1 tim2) )

(define (time<? tim1 tim2)
  (check-time-compare 'time<? tim1 tim2)
  (tm:time<? tim1 tim2) )

(define (time>=? tim1 tim2)
  (check-time-compare 'time>=? tim1 tim2)
  (tm:time>=? tim1 tim2) )

(define (time<=? tim1 tim2)
  (check-time-compare 'time<=? tim1 tim2)
  (tm:time<=? tim1 tim2) )

(define (time-max tim1 . rest)
  (let ((tt (tm:time-type (check-time 'time-max tim1))))
    (let loop ((acc tim1) (ls rest))
      (if (null? ls)
        acc
        (let ((tim (car ls)))
          (check-time-and-type 'time-max tim tt)
          (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )

(define (time-min tim1 . rest)
  (let ((tt (tm:time-type (check-time 'time-min tim1))))
    (let loop ((acc tim1) (ls rest))
      (if (null? ls)
        acc
        (let ((tim (car ls)))
          (check-time-and-type 'time-min tim tt)
          (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )

;; Time Arithmetic

(define (time-difference tim1 tim2)
  (check-time-compare 'time-difference tim1 tim2)
  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )

(define (add-duration tim dur)
  (check-time-aritmetic 'add-duration tim dur)
  (tm:add-duration tim dur (tm:as-some-time tim)) )

(define (subtract-duration tim dur)
  (check-time-aritmetic 'subtract-duration tim dur)
  (tm:subtract-duration tim dur (tm:as-some-time tim)) )

(define (divide-duration dur num)
  (check-duration 'divide-duration dur)
  (tm:divide-duration dur num (tm:some-time 'duration)) )

(define (multiply-duration dur num)
  (check-duration 'multiply-duration dur)
  (tm:multiply-duration dur num (tm:some-time 'duration)) )

(define (time-abs tim)
  (check-time 'time-abs tim)
  (tm:time-abs tim (tm:as-some-time tim)) )

(define (time-negate tim)
  (check-time 'time-negate tim)
  (tm:time-negate tim (tm:as-some-time tim)) )

;;

(define (time-difference! tim1 tim2)
  (check-time-compare 'time-difference! tim1 tim2)
  (tm:time-difference tim1 tim2 tim1) )

(define (add-duration! tim dur)
  (check-time-aritmetic 'add-duration! tim dur)
  (tm:add-duration tim dur tim) )

(define (subtract-duration! tim dur)
  (check-time-aritmetic 'subtract-duration! tim dur)
  (tm:subtract-duration tim dur tim) )

(define (divide-duration! dur num)
  (check-duration 'divide-duration! dur)
  (tm:divide-duration dur num dur) )

(define (multiply-duration! dur num)
  (check-duration 'multiply-duration! dur)
  (tm:multiply-duration dur num dur) )

(define (time-abs! tim)
  (check-time 'time-abs! tim)
  (tm:time-abs tim tim) )

(define (time-negate! tim)
  (check-time 'time-negate! tim)
  (tm:time-negate tim tim) )

;;

(define (time-negative? tim)
  ;nanoseconds irrelevant
  (negative? (tm:time-second (check-time 'time-negative? tim))) )

(define (time-positive? tim)
  ;nanoseconds irrelevant
  (positive? (tm:time-second (check-time 'time-positive? tim))) )

(define (time-zero? tim)
  (check-time 'time-zero? tim)
  (and
    (zero? (tm:time-nanosecond tim))
    (zero? (tm:time-second tim))) )

;; Time Type Conversion

;;

(define (time-tai->time-utc tim)
  (check-time-and-type 'time-tai->time-utc tim 'tai)
  (tm:time-tai->time-utc tim (tm:any-time)) )

(define (time-tai->time-monotonic tim)
  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
  (tm:time-tai->time-monotonic tim (tm:any-time)) )

(define (time-utc->time-tai tim)
  (check-time-and-type 'time-utc->time-tai tim 'utc)
  (tm:time-utc->time-tai tim (tm:any-time)) )

(define (time-utc->time-monotonic tim)
  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
  (tm:time-utc->time-monotonic tim (tm:any-time)) )

(define (time-monotonic->time-utc tim)
  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
  (let ((ntim (tm:copy-time tim)))
    (tm:time-monotonic->time-utc ntim ntim) ) )

(define (time-monotonic->time-tai tim)
  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
  (tm:time-monotonic->time-tai tim (tm:any-time)) )

;;

(define (time-tai->time-utc! tim)
  (check-time-and-type 'time-tai->time-utc! tim 'tai)
  (tm:time-tai->time-utc tim tim) )

(define (time-tai->time-monotonic! tim)
  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
  (tm:time-tai->time-monotonic tim tim) )

(define (time-utc->time-tai! tim)
  (check-time-and-type 'time-utc->time-tai! tim 'utc)
  (tm:time-utc->time-tai tim tim) )

(define (time-utc->time-monotonic! tim)
  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
  (tm:time-utc->time-monotonic tim tim) )

(define (time-monotonic->time-utc! tim)
  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
  (tm:time-monotonic->time-utc tim tim) )

(define (time-monotonic->time-tai! tim)
  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
  (tm:time-monotonic->time-tai tim tim) )

;;

(import (only (chicken read-syntax) define-reader-ctor))
(import (only (chicken format) format))

(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)
    (tm:time-type tim)
    (tm:time-nanosecond tim)
    (tm:time-second tim)) )

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

) ;module srfi-19-time