From 30357bc117aee20b7f43ec40fe5551930a0bf7d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 14 Feb 2020 00:19:05 +0100 Subject: Add datetime-difference. --- module/output/html.scm | 4 ++-- module/srfi/srfi-19/alt.scm | 34 ++++++++++++++++++++++++++++++++++ tests/srfi-19-alt.scm | 22 +++++++++++++++++++--- 3 files changed, 55 insertions(+), 5 deletions(-) diff --git a/module/output/html.scm b/module/output/html.scm index f30e6338..42290ed9 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -120,8 +120,8 @@ (partition (lambda (ev) (or (date? (attr ev 'DTSTART)) (datetime<=? (datetime time: (time hour: 24)) - (datetime- (attr ev 'DTEND) - (attr ev 'DTSTART))))) + (datetime-difference (attr ev 'DTEND) + (attr ev 'DTSTART))))) (stream->list events)))) ;; (format (current-error-port) "lay-out-day: ~a~%" (date->string date)) (format (current-error-port) "long=~a, short=~a~%" diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm index 09f70190..33a1bc1f 100644 --- a/module/srfi/srfi-19/alt.scm +++ b/module/srfi/srfi-19/alt.scm @@ -487,6 +487,40 @@ (date day: overflow)) time: time))) +(define (datetime->srfi-19-date date) + ((@ (srfi srfi-19) make-date) + 0 + (second (get-time date)) + (minute (get-time date)) + (hour (get-time date)) + (day (get-date date)) + (month (get-date date)) + (year (get-date date)) + 0 ; TODO TZ + )) + +(define (srfi-19-date->datetime o) + (let ((y ((@ (srfi srfi-19) date-year) o))) + ;; TODO find better way to translate from 1970 to 0, since this WILL + ;; cause problems sooner or later. + (datetime year: (if (= 1970 y) 0 y) + month: (let ((m ((@ (srfi srfi-19) date-month) o))) + (if (and (= 1970 y) (= 1 m)) 0 m)) + day: (let ((d ((@ (srfi srfi-19) date-day) o))) + (if (and (= 1970 y) (= 1 d)) 0 d)) + hour: ((@ (srfi srfi-19) date-hour) o) + minute: ((@ (srfi srfi-19) date-minute) o) + second: ((@ (srfi srfi-19) date-second) o) + ))) + + +(define-public (datetime-difference end start) + (let ((t + ((@ (srfi srfi-19) time-difference) + ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date end)) + ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date start))))) + ((@ (srfi srfi-19) set-time-type!) t (@ (srfi srfi-19) time-utc)) + (srfi-19-date->datetime ((@ (srfi srfi-19) time-utc->date) t 0)))) ; TODO tz offset ;;; Parsers for vcomponent usage diff --git a/tests/srfi-19-alt.scm b/tests/srfi-19-alt.scm index 1a351992..51419fcc 100644 --- a/tests/srfi-19-alt.scm +++ b/tests/srfi-19-alt.scm @@ -6,10 +6,15 @@ datetime+ datetime- datetime<=? + datetime-difference + leap-year? ) ((ice-9 format) format) ) +(test-equal "empty time" + (time) #00:00:00) + (test-assert "Synatx date" #2020-01-01) @@ -91,9 +96,9 @@ #00:00:00 (time- #10:20:30 #10:20:30)) -(test-equal "date- self" - #0000-00-00 - (date- #2020-01-01 #2020-01-01)) +(test-equal "datetime-difference self" + #0000-00-00T00:00:00 + (datetime-difference (datetime date: #2020-01-01) (datetime date: #2020-01-01))) ;; (test-assert ;; (datetime- #2018-01-17T10:00:00 @@ -105,3 +110,14 @@ ;; (datetime- #2018-01-17T10:00:00 ;; #2018-01-17T08:00:00))) + +;; TODO +;; at the time of writing this returns #2020-02-00 +;; The general question is, how is the last in a month handled? +;; (test-equal +;; (date+ #2019-12-31 (date month: 1))) + +(test-assert (leap-year? 2020)) + +(test-equal "Add to Leap day" + #2020-02-29 (date+ #2020-02-28 (date day: 1))) -- cgit v1.2.3