path: root/modules/language/python/module/time.scm

(define-module (language python module time)
  #:use-module (srfi srfi-19)
  #:use-module (language python string)
  #:use-module (language python try)
  #:use-module (language python exceptions)
  #:use-module (language python list)
  #:use-module (language python def)
  #:use-module (language python module errno)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (oop pf-objects)

  #:export (asctime clock
                    CLOCK_REALTIME CLOCK_MONOTONIC CLOCK_PROCESS CLOCK_THREAD
                    CLOCK_MONOTONIC CLOCK_REALTIME CLOCK_MONOTONIC
                    CLOCK_BOOTTIME CLOCK_REALTIME CLOCK_BOOTTIME CLOCK_TAI
                    clock_getres clock_gettime clock_settime time ctime
                    get_clock_info gmtime localtime mktime monotonic
                    pref_counter process_time sleep strftime strptime tzset
                    timezone altzone daylight tzname))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define-syntax-rule (ca code)
  (catch #t
    (lambda () code)
    (lambda x (raise error x))))

(define-syntax-rule (rm code)
  (let ((r (ca code)))
    (if (< r 0)
        (raise error (errno) ((@ (guile) strerror) (errno)))
        r)))

(define (scmdate t)
  (cond
   ((number? t)
    ((@ (guile) local-time) (inexact->exact (floor (* t 1.0)))))
   ((struct? t)
    ((ref t 'guile)))
   (else t)))

(define-python-class namespace ()
  (define __init__
    (lam (self (**  kw))
         (set self '_kw kw)))

  (define __getitem__
    (lambda (self x)
      (pylist-ref (ref self '_kw) x)))

  (define __repr__
    (lambda (self)
      (format #f "~a" (ref self '_kw)))))

    
(define-python-class struct_time ()
  (define* __init__
    (lambda (self x)
      (cond
       ((number? x)
        (__init__ self ((@ (guile) localtime)
                        (inexact->exact (floor (* 1.0 x))))))
       ((vector? x)
        (set self 'tm_year   (+ 1900 (tm:year   x)))
        (set self 'tm_mon    (+ 1    (tm:mon    x)))
        (set self 'tm_mday   (tm:mday   x))
        (set self 'tm_hour   (tm:hour   x))
        (set self 'tm_min    (tm:min    x))
        (set self 'tm_sec    (tm:sec    x))
        (set self 'tm_wday   (tm:wday   x))
        (set self 'tm_yday   (+ 1 (tm:yday   x)))
        (set self 'tm_isdst  (tm:isdst  x))
        (set self 'tm_zone   (tm:zone   x))
        (set self 'tm_gmtoff (tm:gmtoff x)))
       (else
        (set self 'tm_year   (ref x 'tm_year))
        (set self 'tm_mon    (ref x 'tm_mon))
        (set self 'tm_mday   (ref x 'tm_mday))
        (set self 'tm_hour   (ref x 'tm_hour))
        (set self 'tm_min    (ref x 'tm_min))
        (set self 'tm_sec    (ref x 'tm_sec))
        (set self 'tm_wday   (ref x 'tm_wday))
        (set self 'tm_yday   (ref x 'tm_yday))
        (set self 'tm_isdst  (ref x 'tm_isdst))
        (set self 'tm_zone   (ref x 'tm_zone))
        (set self 'tm_gmtoff (ref x 'tm_gmtoff))))))

  (define guile
    (lambda (self)
      (let ((res ((@ (guile) localtime) 0)))
        (set-tm:year   res (- (ref self 'tm_year) 1900))
        (set-tm:mon    res (- (ref self 'tm_mon) 1))
        (set-tm:mday   res (ref self 'tm_day))
        (set-tm:hour   res (ref self 'tm_hour))
        (set-tm:min    res (ref self 'tm_min))
        (set-tm:sec    res (ref self 'tm_sec))
        (set-tm:wday   res (ref self 'tm_wday))
        (set-tm:yday   res (- (res self 'tm_yday) 1))
        (set-tm:isdst  res (ref self 'tm_isdst))
        (set-tm:zone   res (ref self 'tm_zone))
        (set-tm:gmtoff res (ref self 'tm_gmtoff))
        res)))
  
  (define __repr__
    (lambda (self)
      (format #f "date(year ~a, mon ~a, day ~a, hour ~a, min ~a, sec ~a : ~a)"
              (ref self 'tm_year)
              (ref self 'tm_mon)
              (ref self 'tm_mday)
              (ref self 'tm_hour)
              (ref self 'tm_min)
              (ref self 'tm_sec)
              (ref self 'tm_zone))))
  
  (define __getitem__
    (lambda (self n)
      (case n
        ((0) (ref self 'tm_year))
        ((1) (ref self 'tm_month))
        ((2) (ref self 'tm_mday))
        ((3) (ref self 'tm_hour))
        ((4) (ref self 'tm_min))
        ((5) (ref self 'tm_sec))
        ((6) (ref self 'tm_wday))
        ((7) (ref self 'tm_yday))
        ((8) (ref self 'tm_isdst))
        (else
         (raise KeyError "date index out of bound [0,8] got" n))))))

(define (date-scm x) (ref x '_date))

(define* (asctime #:optional (t None))
  (ca
   (let ((t2 (let lp ((t t))
               (cond
                ((eq? t None)
                 (current-date))
                ((number? t)
                 (lp (make-time time-utc 0
                                (inexact->exact (floor (* t 1.0))))))
                ((time? t)
                 (time-utc->date t))

                ((vector? t)
                 (lp ((@ (guile) mktime) t)))

                ((struct? t)
                 (lp (scmdate t)))))))
     (date->string t2))))

(define (clock)
  (let ((t (current-time time-process)))
    (+ (time-second t) (/ (time-nanosecond t) 1000000000.0))))

(define CLOCK_REALTIME                 0)
(define CLOCK_MONOTONIC                1)
(define CLOCK_PROCESS_CPUTIME_ID       2)
(define CLOCK_THREAD_CPUTIME_ID        3)
(define CLOCK_MONOTONIC_RAW            4)
(define CLOCK_REALTIME_COARSE          5)
(define CLOCK_MONOTONIC_COARSE         6)
(define CLOCK_BOOTTIME                 7)
(define CLOCK_REALTIME_ALARM           8)
(define CLOCK_BOOTTIME_ALARM           9)
(define CLOCK_TAI                      11)

(define clock_getres
  (let ((f (pointer->procedure int
                               (dynamic-func "clock_getres" (dynamic-link))
                               (list int '*))))
    (lambda (clk_id)
      (let* ((v  (make-bytevector 16))
             (vp (bytevector->pointer v))) 
        (rm (f clk_id vp))
        (+ (bytevector-s64-ref v 0 (native-endianness))
           (/ (bytevector-s64-ref v 8 (native-endianness))
              1e9))))))

(define clock_gettime
  (let ((f (pointer->procedure int
                               (dynamic-func "clock_gettime" (dynamic-link))
                               (list int '*))))
    (lambda (clk_id)
      (let* ((v  (make-bytevector 16))
             (vp (bytevector->pointer v))) 
        (rm (f clk_id vp))
        (+ (bytevector-s64-ref v 0 (native-endianness))
           (/ (bytevector-s64-ref v 8 (native-endianness))
              1e9))))))

(define clock_settime
  (let ((f (pointer->procedure int
                               (dynamic-func "clock_settime" (dynamic-link))
                               (list int '*))))
    (lambda (clk_id time)
      (let* ((v  (make-bytevector 16))
             (vp (bytevector->pointer v))
             (a  (inexact->exact (floor time)))
             (b  (modulo (inexact->exact (* (floor time) 1e9)) 1000000000)))
        (bytevector-s64-set! v 0 a (native-endianness))
        (bytevector-s64-set! v 8 b (native-endianness))
        (rm (f clk_id vp))
        (values)))))

(define  (time)  (clock_gettime CLOCK_REALTIME))

(define* (ctime #:optional (sec None))
  (define sec2 (if (eq? sec None) (time) sec))
  (ca (date->string (time-utc->date sec2))))

(define (get_clock_info name2)
  (define name (scm-str name2))
  (cond
   ((equal? name "clock")
    (namespace #:adjustable     #t
               #:implementation "clock()"
               #:monotonic      #f
               #:resolution     1e-6))

   ((equal? name "monotonic")
    (namespace #:adjustable     #f
               #:implementation "clock_gettime(CLOCK_MONOTONIC)"
               #:monotonic      #t
               #:resolution     (clock_getres CLOCK_MONOTONIC)))

   ((equal? name "perf_counter")
    (namespace #:adjustable     #f
               #:implementation "clock_gettime(CLOCK_MONOTONIC)"
               #:monotonic      #t
               #:resolution     (clock_getres CLOCK_MONOTONIC)))

   ((equal? name "process_time")
    (namespace #:adjustable     #f
               #:implementation "clock_gettime(CLOCK_PROCESS_CPUTIME_ID)"
               #:monotonic      #t
               #:resolution     (clock_getres CLOCK_PROCESS_CPUTIME_ID)))

   ((equal? name "time")
    (namespace #:adjustable     #t
               #:implementation "clock_gettime(CLOCK_REALTIME)"
               #:monotonic      #f
               #:resolution     (clock_getres CLOCK_REALTIME)))))

(define* (gmtime #:optional (secs None))
  (define secs2 (inexact->exact
                 (floor (if (eq? secs None) (time) secs))))
  (ca (struct_time ((@ (guile) gmtime) secs2))))

(define* (localtime #:optional (secs None))
  (define secs2 (inexact->exact
                 (floor (if (eq? secs None) (time) secs))))
  (ca (struct_time ((@ (guile) localtime) secs2))))

(define (mktime t)
  (ca (car (mktime (ref t 'guile-repr)))))


(define (monotonic)     (clock_gettime CLOCK_MONOTONIC))
(define (pref_counter)  (clock_gettime CLOCK_MONOTONIC))
(define (process_time)  (clock_gettime CLOCK_PROCESS_CPUTIME_ID))
(define (sleep secs)
  (usleep (inexact->exact (floor (* secs 1e6)))))

(define* (strftime format #:optional (t None))
  (define t2 (if (eq? t None) (localtime) t))
  (ca ((@ (guile) strftime) (scm-str format) (scmdate t2))))
  
(define* (strptime string #:optional (format None))
  (define format2 (if (eq? format None)
                      "%a %b %d %H:%M:%S %Y"
                      (scm-str format)))
  (define string2 (scm-str string))
  (let ((res (ca ((@ (guile) strptime) format2 string2))))
    (if (= (cdr res) 0)
        (struct_time (car res))
        (raise ValueError "charcter unparsed " (cdr res)))))

(define tzset (@ (guile) tzset))

(define winter
  (let* ((x ((@ (guile) current-time)))
         (d ((@ (guile) localtime) x))
         (y (- x (* (tm:mday d) 3600 24))))
    y))

(define summer
  (let* ((x ((@ (guile) current-time)))
         (d ((@ (guile) localtime) x))
         (y (+ (- x (* (tm:mday d) 3600 24)) (* (/ 364 2) 3600 24))))
    y))

(define timezone (tm:gmtoff ((@ (guile) localtime) 0)))
  
(define altzone
  (let ((s (tm:gmtoff ((@ (guile) localtime) summer)))
        (w (tm:gmtoff ((@ (guile) localtime) winter))))
    (if (= s timezone) w s)))
           
(define daylight (tm:isdst ((@ (guile) localtime) summer)))

(define tzname
  (list (tm:zone ((@ (guile) localtime) winter))
        (tm:zone ((@ (guile) localtime) summer))))