From 3527bb143b6a6740a9f51b0eaf87c883060c86bc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 25 Jun 2020 18:07:42 +0200
Subject: Merge UTC-OFFSET and TIMESPEC into one.

---
 module/datetime/timespec.scm | 92 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 92 insertions(+)
 create mode 100644 module/datetime/timespec.scm

(limited to 'module/datetime/timespec.scm')

diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm
new file mode 100644
index 00000000..ae8b3d9b
--- /dev/null
+++ b/module/datetime/timespec.scm
@@ -0,0 +1,92 @@
+;;; Commentary:
+;; Datatype for holding timechanges and time offesets.
+;; Used both for timespecs from the TZ-database, and for UTC-OFFSET from RFC5545.
+;;; Code:
+
+(define-module (datetime timespec)
+  :use-module (util)
+  :use-module (util exceptions)
+  :use-module (datetime)
+  :use-module (datetime util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9 gnu)
+  )
+
+
+;; timespec as defined by the TZ-database
+;; also used UTC-OFFSET defined by RFC5545. Then type should equal #\z
+;; and be ignored.
+(define-immutable-record-type <timespec> ; EXPORTED
+  (make-timespec timespec-time sign type)
+  timespec?
+  (timespec-time timespec-time)         ; <time>
+  (sign timespec-sign)                  ; '+ | '-
+  ;; types:
+  ;; w - wall clock time (local time)
+  ;; s - standard time without daylight savings adjustments
+  ;; u, g, z - Universal time
+  (type timespec-type))                 ; char
+
+(export make-timespec timespec? timespec-time timespec-sign timespec-type)
+
+(define-public (timespec-zero)
+  (make-timespec (time) '+ #\w))
+
+(define-public (timespec-add . specs)
+  (unless (apply eqv? (map timespec-type specs))
+    (warning "Adding timespecs of differing types"))
+
+  (reduce (lambda (spec done)
+            (cond
+             ;; - -
+             ;; + +
+             [(eq? (timespec-sign done)
+                   (timespec-sign spec))
+              (set (timespec-time done) = (time+ (timespec-time spec)))]
+             ;; - +
+             [(and (eq? '- (timespec-sign done))
+                   (eq? '+ (timespec-sign spec)))
+              (let ((time-a (timespec-time done))
+                    (time-b (timespec-time spec)))
+                (if (time< time-a time-b)
+                    (make-timespec (time- time-b time-a)
+                                   '+ (timespec-type done))
+                    (set (timespec-time done) (time- time-b))))]
+             ;; + -
+             [(and (eq? '+ (timespec-sign done))
+                   (eq? '- (timespec-sign spec)))
+              (let ((time-a (timespec-time done))
+                    (time-b (timespec-time spec)))
+                (if (time< time-a time-b)
+                    (make-timespec (time- time-b time-a)
+                                   '- (timespec-type done))
+                    (set (timespec-time done) (time+ time-b))))]))
+          (timespec-zero)
+          specs))
+
+
+(define (parse-time string)
+  (apply (lambda* (hour optional: (minute "0") (second "0"))
+           (time hour: (string->number hour)
+                 minute: (string->number minute)
+                 ;; discard sub-seconds
+                 second: (string->number (car (string-split second #\.)))))
+         (string-split string #\:)))
+
+
+(define*-public (parse-time-spec
+                 string optional: (suffixes '(#\s #\w #\u #\g #\z)))
+  (let* ((type string
+          (cond [(string-rindex string (list->char-set suffixes))
+                 => (lambda (idx)
+                      (values (string-ref string idx)
+                              (substring string 0 idx)))]
+                [else (values #\w string)])))
+    (cond [(string=? "-"  string)
+           (make-timespec (time) '+ type)]
+          [(string-prefix? "-" string)
+           (make-timespec (parse-time (string-drop string 1))
+                          '- type)]
+          [else
+           (make-timespec (parse-time string)
+                          '+ type)])))
-- 
cgit v1.2.3