aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--module/entry-points/ical.scm8
-rw-r--r--module/entry-points/terminal.scm9
-rw-r--r--module/output/ical.scm4
-rw-r--r--module/output/terminal.scm31
-rw-r--r--module/srfi/srfi-19/alt.scm348
-rw-r--r--module/srfi/srfi-19/alt/util.scm107
-rw-r--r--module/srfi/srfi-19/util.scm28
-rw-r--r--module/vcomponent/datetime.scm25
-rw-r--r--module/vcomponent/group.scm4
-rw-r--r--module/vcomponent/load.scm6
-rw-r--r--module/vcomponent/parse.scm36
-rw-r--r--module/vcomponent/recurrence/parse.scm7
-rw-r--r--module/vulgar/components.scm6
-rw-r--r--tests/srfi-19-alt.scm5
14 files changed, 533 insertions, 91 deletions
diff --git a/module/entry-points/ical.scm b/module/entry-points/ical.scm
index 87b4a6fe..375613a3 100644
--- a/module/entry-points/ical.scm
+++ b/module/entry-points/ical.scm
@@ -5,8 +5,8 @@
:use-module ((vcomponent) :select (load-calendars*))
:use-module ((parameters) :select (calendar-files))
:use-module (ice-9 getopt-long)
- :use-module (srfi srfi-19)
- :use-module (srfi srfi-19 util)
+ :use-module (srfi srfi-19 alt)
+ :use-module (srfi srfi-19 alt util)
)
(define opt-spec
@@ -20,7 +20,9 @@
(define start (cond [(option-ref opts 'from #f) => parse-freeform-date]
[else (start-of-month (current-date))]))
(define end (cond [(option-ref opts 'to #f) => parse-freeform-date]
- [else (normalize-date* (set (date-month start) = (+ 1)))]))
+ ;; [else (normalize-date* (set (month start) = (+ 1)))]
+ [(date+ start (date month: 1))]
+ ))
;; TODO this contains repeated events multiple times
(define-values (calendars regular repeating)
diff --git a/module/entry-points/terminal.scm b/module/entry-points/terminal.scm
index 45f9b8eb..df15116c 100644
--- a/module/entry-points/terminal.scm
+++ b/module/entry-points/terminal.scm
@@ -3,8 +3,8 @@
:use-module (output terminal)
:use-module (vcomponent)
:use-module (ice-9 getopt-long)
- :use-module (srfi srfi-19)
- :use-module (srfi srfi-19 util)
+ :use-module (srfi srfi-19 alt)
+ :use-module (srfi srfi-19 alt util)
:use-module (parameters)
:use-module (vulgar)
)
@@ -20,9 +20,8 @@
calendar-files: (cond [(option-ref opts 'file #f) => list]
[else (calendar-files)]) ))
- (let ((time (date->time-utc
- (drop-time (or (and=> (option-ref opts 'date #f) parse-freeform-date)
- (current-date))))))
+ (let ((time (drop-time (or (and=> (option-ref opts 'date #f) parse-freeform-date)
+ (current-date)))))
;; (format (current-error-port) "len(events) = ~a~%" (stream-length events))
(with-vulgar
(lambda () (main-loop time events))))
diff --git a/module/output/ical.scm b/module/output/ical.scm
index 6fedc391..c7a6503c 100644
--- a/module/output/ical.scm
+++ b/module/output/ical.scm
@@ -4,8 +4,8 @@
:use-module (util)
:use-module (vcomponent)
:use-module (srfi srfi-1)
- :use-module (srfi srfi-19)
- :use-module (srfi srfi-19 util)
+ :use-module (srfi srfi-19 alt)
+ :use-module (srfi srfi-19 alt util)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
)
diff --git a/module/output/terminal.scm b/module/output/terminal.scm
index 8b113c82..ece11a4b 100644
--- a/module/output/terminal.scm
+++ b/module/output/terminal.scm
@@ -2,8 +2,8 @@
#:use-module (output general)
#:use-module (output text)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-19)
- #:use-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-19 alt)
+ #:use-module (srfi srfi-19 alt util)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-41)
#:use-module (srfi srfi-41 util)
@@ -63,7 +63,7 @@
(define (displayln a)
(display a) (newline))
-(define (main-loop time event-stream)
+(define (main-loop date event-stream)
(define cur-event 0)
(define-values (height width) (get-terminal-size))
@@ -74,14 +74,14 @@
;; TODO reusing the same grouping causes it to lose events.
;; I currently have no idea why, but it's BAD.
(let ((groups (get-groups-between grouped-stream
- (time-utc->date time) (time-utc->date time))))
+ date date)))
(format (current-error-port) "len(groups) = ~a~%" (stream-length groups))
(let ((events
(if (stream-null? groups)
'() (group->event-list (stream-car groups)))))
(cls)
- (display-calendar-header! (time-utc->date time))
+ (display-calendar-header! date)
(let* ((date-width 20)
(location-width 15)
@@ -103,8 +103,16 @@
(attr ev 'SUMMARY)
(or (and=> (attr ev 'LOCATION)
(cut string-append "\x1b[1mPlats:\x1b[m " <> "\n")) "")
- (time->string (attr ev 'DTSTART) "~1 ~3")
- (time->string (attr ev 'DTEND) "~1 ~3")
+ (let ((start (attr ev 'DTSTART)))
+ (if (datetime? start)
+ (string-append (date->string (date start))
+ (time->string (time start)))
+ (date->string (date start))))
+ (let ((end (attr ev 'DTEND)))
+ (if (datetime? start)
+ (string-append (date->string (date end))
+ (time->string (time end)))
+ (date->string (date end))))
(unlines (take-to (flow-text (or (attr ev 'DESCRIPTION) "")
#:width (min 70 width))
(- height 8 5 (length events) 5))))))
@@ -114,13 +122,13 @@
;; "c = ~c (~d)~%" char (char->integer char))
(case char
((#\L #\l)
- (set! time (add-day time)
+ (set! time (add-day date)
cur-event 0))
((#\h #\H)
- (set! time (remove-day time)
+ (set! time (remove-day date)
cur-event 0))
((#\t)
- (set! time (date->time-utc (drop-time (current-date)))
+ (set! time (current-date)
cur-event 0))
((#\j #\J) (unless (= cur-event (1- (length events)))
(mod! cur-event 1+)))
@@ -128,7 +136,8 @@
(mod! cur-event 1-)))
((#\p) (print-vcomponent (list-ref events cur-event)
(current-error-port)))
- ((#\E) (serialize-vcomponent (list-ref events cur-event) (open-output-file "/tmp/event.ics")))
+ ((#\E) (serialize-vcomponent (list-ref events cur-event)
+ (open-output-file "/tmp/event.ics")))
((#\e)
(let ((fname (tmpnam)))
(with-output-to-file fname
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm
new file mode 100644
index 00000000..b3e8a478
--- /dev/null
+++ b/module/srfi/srfi-19/alt.scm
@@ -0,0 +1,348 @@
+(define-module (srfi srfi-19 alt)
+ :export (date? year month day
+ hour minute second
+ time? datetime?
+ )
+
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-9 gnu)
+ :use-module (ice-9 match)
+
+ :use-module (util)
+ )
+
+(define-many define-public
+ (jan january ) 1
+ (feb february ) 2
+ (mar mars ) 3
+ (apr april ) 4
+ (may ) 5
+ (jun june ) 6
+ (jul july ) 7
+ (aug august ) 8
+ (sep september ) 9
+ (oct october ) 10
+ (nov november ) 11
+ (dec december ) 12
+ )
+
+(define-immutable-record-type <date>
+ (make-date year month day)
+ date?
+ (year year) (month month) (day day))
+
+(set-record-type-printer!
+ <date>
+ (lambda (r p)
+ (format p "~4'0d­~2'0d­~2'0d"
+ (year r) (month r) (day r))))
+
+(define*-public (date key: (year 0) (month 0) (day 0))
+ (make-date year month day))
+
+
+;; int -> bool
+(define-public (leap-year? year)
+ (and (zero? (remainder year 4))
+ (or (zero? (remainder year 400))
+ (not (zero? (remainder year 100))))))
+
+;; Returns number of days month for a given date. Just looks at the year and month components.
+(define-public (days-in-month date)
+ (case* (month date)
+ ((jan mar may jul aug oct dec) 31)
+ ((apr jun sep nov) 30)
+ ((feb)
+ (if (leap-year? (year date))
+ 29 28))))
+
+(define-public (days-in-year date)
+ (if (leap-year? (year date))
+ 366 365))
+
+;; 2020-01-10 + 0-0-30 = 2020-02-09
+;; 10 + 30 = 40 ; day + day
+;; 40 > 31 ; target days > days in month
+;; 2020-02-00 + 0-0- (40 - 31) ;
+;; 2020-02-09
+
+(define-public (date= a b)
+ (and (= (year a) (year b))
+ (= (month a) (month b))
+ (= (day a) (day b))))
+
+(define-public date=? date=)
+
+(define (date+% base change)
+
+ ;; while (day base) > (days-in-month base)
+ ;; month++; days -= (days-in-month base)
+ (define days-fixed
+ (let loop ((target (set (day base) = (+ (day change)))))
+ (if (> (day target) (days-in-month target))
+ (loop (set-> target
+ (month = (+ 1))
+ (day = (- (days-in-month target)))))
+ target)))
+
+ ;; while (month base) > 12
+ ;; year++; month -= 12
+ (define months-fixed
+ (let loop ((target (set (month days-fixed) = (+ (month change)))))
+ (if (> (month target) 12)
+ (loop (set-> target
+ (year = (+ 1))
+ (month = (- 12))))
+ target)))
+
+ (set (year months-fixed) = (+ (year change))))
+
+(define-public (date+ base . rest)
+ (fold date+% base rest))
+
+(define-public (date- base change)
+
+ (define-values (days-fixed change*)
+ (let loop ((target base) (change change))
+ (if (>= (day change) (day target))
+ (loop (set-> target
+ (month = (- 1))
+ (day (days-in-month (set (month target) = (- 1)))))
+ (set (day change) = (- (day target))))
+ (values (set (day target) = (- (day change)))
+ (set (day change) 0)))))
+
+ (define-values (month-fixed change**)
+ (let loop ((target days-fixed) (change change*))
+ (if (>= (month change) (month target))
+ (loop (set-> target
+ (year = (- 1))
+ (month 12))
+ (set (month change) = (- (month target))))
+ (values (set (month target) = (- (month change)))
+ (set (month change) 0)))))
+
+ ;; change** should here should have both month and date = 0
+
+ (set (year month-fixed) = (- (year change))))
+
+(define-public (time- base change)
+
+ (define-values (second-fixed change*)
+ (let loop ((target base) (change change))
+ (if (> (second change) (second target))
+ (loop (set-> target
+ (minute = (- 1))
+ (second 60))
+ (set (second change) = (- (second target))))
+ (values (set (second target) = (- (second change)))
+ (set (second change) 0)))))
+
+ (define-values (minute-fixed change**)
+ (let loop ((target second-fixed) (change change*))
+ (if (> (minute change) (minute target))
+ (loop (set-> target
+ (hour = (- 1))
+ (minute 60))
+ (set (minute change) = (- (minute target))))
+ (values (set (minute target) = (- (minute change)))
+ (set (minute change) 0)))))
+
+ ;; change** should here should have both month and date = 0
+
+ (set (hour month-fixed) = (- (hour change)))
+ )
+
+
+
+(define-immutable-record-type <time>
+ (make-time hour minute second utc)
+ time?
+ (hour hour) (minute minute) (second second)
+ (utc utc) ; bool
+ )
+
+(set-record-type-printer!
+ <time>
+ (lambda (r p)
+ (format p "~2'0d:~2'0d:~2'0d~a"
+ (hour r) (minute r) (second r)
+ (if (utc r) "Z" ""))))
+
+(define-public (time->string time _)
+ (with-output-to-string (lambda () (display time))))
+
+(define*-public (time key: (hour 0) (minute 0) (second 0) (utc #f))
+ (make-time hour minute second utc))
+
+(define-public (time+% base change)
+
+ ;; while (day base) > (days-in-month base)
+ ;; month++; days -= (days-in-month base)
+ (define second-fixed
+ (let loop ((target (set (second base) = (+ (second change)))))
+ (if (>= (second target) 60)
+ (loop (set-> target
+ (minute = (+ 1))
+ (second = (- 60))))
+ target)))
+
+ ;; while (month base) > 12
+ ;; year++; month -= 12
+ (define minute-fixed
+ (let loop ((target (set (minute second-fixed) = (+ (minute change)))))
+ (if (>= (minute target) 60)
+ (loop (set-> target
+ (hour = (+ 1))
+ (minute = (- 60))))
+ target)))
+
+ ;; ahtns auoe htns a oeuhnstaoue nhts aoeu nshtaoeu snht oeuia htns oaeu nsht aoeuö ntshaouentsh oaesnuthg aoeu nsthaoeu nshtaou eshtnnh toaeuhnst oeuhtns
+ (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change))))
+
+ ;; (format #t "~s ~s ~s~%" second-fixed minute-fixed hour-almost-fixed)
+
+ (if (<= 24 (hour hour-almost-fixed))
+ (let* ((div remainder (floor/ (hour hour-almost-fixed) 24)))
+ (values (set (hour hour-almost-fixed) remainder) div))
+ (values hour-almost-fixed 0)))
+
+(define-public (time+ base . rest)
+ (fold time+% base rest))
+
+(define-immutable-record-type <datetime>
+ (make-datetime date time tz)
+ datetime?
+ (date get-date set-date!)
+ (time get-time set-time!)
+ (tz get-tz set-tz!))
+
+(export get-date get-time get-tz)
+
+(define*-public (make-datetime*
+ key:
+ (year 0) (month 0) (day 0)
+ (hour 0) (minute 0) (second 0)
+ (tz #f))
+ (make-datetime (make-date year month day)
+ (make-time hour minute second #f)
+ tz))
+
+(define-public datetime
+ (match-lambda*
+ [(date time) (make-datetime date time #f)]
+ [(date time tz) (make-datetime date time #f)]
+ [args (apply make-datetime* args)]))
+
+(define-public (datetime+ base change)
+ (let* ((time overflow (time+ (get-time base) (get-time change))))
+ (date+ (get-date base)
+ (get-date change)
+ (date day: overflow))))
+
+
+
+(define-public (date< a b)
+ (let ((ay (year a))
+ (by (year b)))
+ (if (= ay ay)
+ (let ((am (month a))
+ (bm (month b)))
+ (if (= am bm)
+ (< (day a) (day b))
+ (< am bm)))
+ (< ay by))))
+
+
+(define-public (time< a b)
+ (let ((ah (hour a))
+ (bh (hour b)))
+ (if (= ah ah)
+ (let ((am (minute a))
+ (bm (minute b)))
+ (if (= am bm)
+ (< (second a) (second b))
+ (< am bm)))
+ (< ah bh))))
+
+
+(define-public (datetime< a b)
+ (if (date= (get-date a) (get-date b))
+ (time< (get-time a) (get-time b))
+ (date< (get-date a) (get-date b))))
+
+
+(define-many define-public
+ (date<?) date<
+ (date> date>?) (swap date<)
+
+ (time<?) time<
+ (time> time>?) (swap time<)
+
+ (datetime<?) datetime<
+ (datetime> datetime>?) (swap datetime<))
+
+
+
+;; substring to number, local here
+(define (s->n str from to)
+ (string->number (substring/read-only str from to)))
+
+(define-public (parse-date str)
+ (date year: (s->n str 0 4)
+ month: (s->n str 4 6)
+ day: (s->n str 6 8)))
+
+(define-public (parse-time str)
+ (time hour: (s->n str 0 2)
+ minute: (s->n str 2 4)
+ second: (s->n str 4 6)
+ ;; TODO UTC
+ ))
+
+(define-public (parse-datetime str)
+ (let* (((datestr timestr) (string-split str #\T)))
+ (datetime (parse-date datestr)
+ (parse-time timestr))))
+
+
+(define-public (current-date)
+ (let ((d ((@ (srfi srfi-19) current-date))))
+ (date year: ((@ (srfi srfi-19) date-year) d)
+ month: ((@ (srfi srfi-19) date-month) d)
+ day: ((@ (srfi srfi-19) date-day) d))))
+
+
+
+
+
+;; Reader extensions
+
+(define (parse-date% str)
+ (let* (((year month day) (map string->number (string-split str #\-))))
+ `(date year: ,year month: ,month day: ,day)))
+
+(define (parse-time% timestr)
+ (let* (((hour minute second) (string-split timestr #\:)))
+ (let ((utc? (string-contains second "Z")))
+ (let ((hour (string->number hour))
+ (minute (string->number minute))
+ (second (string->number (if utc? (string-drop-right second 1) second))))
+ `(time hour: ,hour minute: ,minute second: ,second utc: ,utc?)))))
+
+(define (parse-datetime% str)
+ (let* (((date time) (string-split str #\T)))
+ `(datetime ,(parse-date date)
+ ,(parse-time time))))
+
+(define (date-reader chr port)
+ (unread-char chr port)
+ (let ((line (symbol->string (read port))))
+ (cond [(string-contains line "T") (parse-datetime% line)]
+ [(string-contains line ":") (parse-time% line)]
+ [(string-contains line "-") (parse-date% line)])))
+
+(read-hash-extend #\0 date-reader)
+(read-hash-extend #\1 date-reader)
+(read-hash-extend #\2 date-reader)
diff --git a/module/srfi/srfi-19/alt/util.scm b/module/srfi/srfi-19/alt/util.scm
new file mode 100644
index 00000000..9b394105
--- /dev/null
+++ b/module/srfi/srfi-19/alt/util.scm
@@ -0,0 +1,107 @@
+(define-module (srfi srfi-19 alt util)
+ :use-module (srfi srfi-19 alt)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-26)
+ :use-module (srfi srfi-41)
+ :use-module (util)
+ )
+
+(define-public (start-of-month date)
+ (set (day date) 0))
+
+
+(define-public (parse-freeform-date str)
+ (let* (((year month day) (map string->number (string-split str #\-))))
+ (date year: year month: month day: day)
+ ))
+
+(define-public (day-stream start-day)
+ (stream-iterate (cut date+ <> #0-0-1)
+ start-day))
+
+(define (as-date date/-time)
+ (if (date? date/-time)
+ date/-time
+ (get-date date/-time)))
+
+(define (as-time date/-time)
+ (if (datetime? date/-time)
+ (get-time date/-time)
+ #00:00:00))
+
+(define-public (date/-time< a b)
+ (if (date< (as-date a) (as-date b))
+ #t
+ (time< (as-time a) (as-time b))))
+
+(define-public date/-time<? date/-time<)
+
+(define*-public (date->string date optional: (fmt "~Y-~m-~d"))
+ (with-output-to-string
+ (lambda ()
+ (fold (lambda (token state)
+ (case state
+ ((#\~)
+ (case token
+ ((#\~) (display "~"))
+ ((#\Y) (format #t "~4'0d" (year date)))
+ ((#\m) (format #t "~2'0d" (month date)))
+ ((#\d) (format #t "~2'0d" (day date)))
+ (else (error "Invalid format token ~a" token)))
+ #f)
+ (else (unless (char=? #\~ token) (display token)) token)))
+ #f
+ (string->list fmt)))))
+
+(define*-public (time->string time optional: (fmt "~H:~M:~S"))
+ (with-output-to-string
+ (lambda ()
+ (fold (lambda (token state)
+ (case state
+ ((#\~)
+ (case token
+ ((#\~) (display "~"))
+ ((#\H) (format #t "~2'0d" (hour date)))
+ ((#\M) (format #t "~2'0d" (minute date)))
+ ((#\S) (format #t "~2'0d" (second date)))
+ (else (error "Invalid format token ~a" token)))
+ #f)
+ (else (unless (char=? #\~ token) (display token)) token)))
+ #f
+ (string->list fmt)))))
+
+
+;; @verbatim
+;; A B C D E ¬F
+;; |s1| : |s2| : |s1| : |s2| : : |s1|
+;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | |
+;; | ||s2| : |s1|| | : | || | : | || | : | || | :
+;; | | : | | : | || | : | || | : | || | : |s2|
+;; | | : | | : | | : | | : : | |
+;; @end verbatim
+;;
+;; E is covered by both case A and B.
+(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
+ "Return whetever or not two timespans overlap."
+ (or
+ ;; A
+ (and (date/-time<? s2-begin s1-end)
+ (date/-time<? s1-begin s2-end))
+
+ ;; B
+ (and (date/-time<? s1-begin s2-end)
+ (date/-time<? s2-begin s1-end))
+
+ ;; C
+ (and (date/-time<? s1-begin s2-begin)
+ (date/-time<? s2-end s1-end))
+
+ ;; D
+ (and (date/-time<? s2-begin s1-begin)
+ (date/-time<? s1-end s2-end))))
+
+(define-public (add-day date)
+ (date+ date (date day: 1)))
+
+(define-public (remove-day date)
+ (date- date (date day: 1)))
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
index 77e824ca..f5bd1964 100644
--- a/module/srfi/srfi-19/util.scm
+++ b/module/srfi/srfi-19/util.scm
@@ -73,34 +73,6 @@ attribute set to 0. Can also be seen as \"Start of day\""
(define (remove-day time)
(add-duration time (make-duration (- (* 60 60 24)))))
-;; @verbatim
-;; A B C D E ¬F
-;; |s1| : |s2| : |s1| : |s2| : : |s1|
-;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | |
-;; | ||s2| : |s1|| | : | || | : | || | : | || | :
-;; | | : | | : | || | : | || | : | || | : |s2|
-;; | | : | | : | | : | | : : | |
-;; @end verbatim
-;;
-;; E is covered by both case A and B.
-(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
- "Return whetever or not two timespans overlap."
- (or
- ;; A
- (and (time<? s2-begin s1-end)
- (time<? s1-begin s2-end))
-
- ;; B
- (and (time<? s1-begin s2-end)
- (time<? s2-begin s1-end))
-
- ;; C
- (and (time<? s1-begin s2-begin)
- (time<? s2-end s1-end))
-
- ;; D
- (and (time<? s2-begin s1-begin)
- (time<? s1-end s2-end))))
(define-public (normalize-date date)
(time-utc->date (date->time-utc date)
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index 5bf829a9..c01de7e7 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -1,10 +1,10 @@
(define-module (vcomponent datetime)
#:use-module (vcomponent base)
- #:use-module (srfi srfi-19)
- #:use-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-19 alt)
+ #:use-module (srfi srfi-19 alt util)
#:use-module (util)
- #:export (parse-datetime
+ #:export (#;parse-datetime
event-overlaps?
overlapping?
event-contains?
@@ -12,6 +12,7 @@
)
;;; date time pointer
+#;
(define (parse-datetime dtime)
"Parse the given date[time] string into a date object."
(string->date
@@ -33,30 +34,26 @@ Event must have the DTSTART and DTEND attribute set."
(attr event-b 'DTSTART)
(attr event-b 'DTEND)))
-(define (event-contains? ev time)
+(define (event-contains? ev datetime)
"Does event overlap the date that contains time."
- (let* ((date (time-utc->date time))
- (start (date->time-utc (drop-time date)))
+ (let* ((start (get-date datetime))
(end (add-day start)))
(event-overlaps? ev start end)))
-(define (ev-time<? a b)
- (time<? (attr a 'DTSTART)
- (attr b 'DTSTART)))
+(define-public (ev-time<? a b)
+ (date/-time<? (attr a 'DTSTART)
+ (attr b 'DTSTART)))
;; Returns length of the event @var{e}, as a time-duration object.
(define-public (event-length e)
- (time-difference
+ (time-
(attr e 'DTEND)
(attr e 'DTSTART)))
;; Returns the length of the part of @var{e} which is within the day
;; starting at the time @var{start-of-day}.
(define-public (event-length/day e start-of-day)
- (time-difference
+ (time-
(time-min (add-day start-of-day) (attr e 'DTEND))
(time-max start-of-day (attr e 'DTSTART))))
-(define-public (ev-time<? a b)
- (time<? (attr a 'DTSTART)
- (attr b 'DTSTART)))
diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm
index 46160a3a..acf41999 100644
--- a/module/vcomponent/group.scm
+++ b/module/vcomponent/group.scm
@@ -1,8 +1,8 @@
(define-module (vcomponent group)
#:use-module (vcomponent)
#:use-module (vcomponent datetime)
- #:use-module (srfi srfi-19)
- #:use-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-19 alt)
+ #:use-module (srfi srfi-19 alt util)
#:use-module (srfi srfi-41)
#:use-module (srfi srfi-41 util)
#:export (group-stream get-groups-between))
diff --git a/module/vcomponent/load.scm b/module/vcomponent/load.scm
index 574c1d20..2e69d1f5 100644
--- a/module/vcomponent/load.scm
+++ b/module/vcomponent/load.scm
@@ -2,7 +2,7 @@
:export (load-calendars load-calendars*)
:use-module (util)
:use-module (srfi srfi-1)
- :use-module (srfi srfi-19)
+ :use-module (srfi srfi-19 alt)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
:use-module (parameters)
@@ -43,5 +43,5 @@
;; collection if sorted, but for the time beieng it's much
;; easier to always sort it.
(values calendars
- (sort*! regular time<? (extract 'DTSTART))
- (sort*! repeating time<? (extract 'DTSTART)))))
+ (sort*! regular date/-time<? (extract 'DTSTART))
+ (sort*! repeating date/-time<? (extract 'DTSTART)))))
diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index c4142910..646d1f72 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -3,9 +3,10 @@
:use-module (rnrs bytevectors)
:use-module (srfi srfi-1)
:use-module (srfi srfi-9)
- :use-module (srfi srfi-19)
- :use-module (srfi srfi-19 setters)
- :use-module (srfi srfi-19 util)
+ :use-module (srfi srfi-19 alt)
+ ;; :use-module (srfi srfi-19 setters)
+ :use-module (srfi srfi-19 alt util)
+ :use-module (srfi srfi-26)
:use-module ((ice-9 rdelim) :select (read-line))
:use-module ((ice-9 textual-ports) :select (unget-char))
:use-module ((ice-9 ftw) :select (scandir ftw))
@@ -14,6 +15,7 @@
:use-module (util strbuf)
:use-module (vcomponent base)
:use-module (vcomponent datetime)
+ :use-module (srfi srfi-19 alt util)
)
(use-modules ((rnrs base) #:select (assert)))
@@ -147,25 +149,27 @@
(when (and (eq? 'VEVENT (type component))
(not (attr component 'DTEND)))
(set! (attr component 'DTEND)
- (add-duration (attr component 'DTSTART)
- (make-duration 3600))))
+ (let ((start (attr component 'DTSTART)))
+ (if (date? start)
+ (date+ start (date day: 1))
+ (datetime+ start (datetime time: (time hour: 1)))))))
- (set! component (parent component))
- ]
+ (set! component (parent component))]
[else
;; TODO repeated keys
(let ((it (make-vline str (get-param-table ctx))))
;; Type specific processing
(case (get-line-key ctx)
- [(DTSTART DTEND)
- (with-vline-tz
- it
- ;; TODO many of these are way to low
- (mod! (value it) (compose date->time-utc parse-datetime)))]
- [(RECURRENCE-ID)
- (with-vline-tz
- it (mod! (value it) (compose date->time-utc parse-datetime)))])
+ [(DTSTART DTEND RECURRENCE-ID)
+
+ (let ((v (prop it 'VALUE)))
+ (mod! (value it)
+ (if (or (and=>> v car (cut string=? <> "DATE-TIME"))
+ (string-contains (value it) "T"))
+ parse-datetime parse-date)))]
+
+ )
;; From RFC 5545 §3.6.1
@@ -298,7 +302,7 @@ row ~a column ~a ctx = ~a
(set! (attr head 'X-HNH-ALTERNATIVES)
(sort*! rest ;; HERE
- time<? (extract 'RECURRENCE-ID)))
+ date/-time< (extract 'RECURRENCE-ID)))
(add-child! calendar head))])
;; return
diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
index 680a818e..f532987a 100644
--- a/module/vcomponent/recurrence/parse.scm
+++ b/module/vcomponent/recurrence/parse.scm
@@ -4,10 +4,9 @@
#:export (parse-recurrence-rule)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-19) ; Datetime
- #:use-module (srfi srfi-19 util)
+ #:use-module (srfi srfi-19 alt) ; Datetime
+ #:use-module (srfi srfi-19 alt util)
#:use-module (srfi srfi-26)
- #:use-module ((vcomponent datetime) #:select (parse-datetime))
#:use-module (vcomponent recurrence internal)
#:use-module (util)
#:use-module (ice-9 match))
@@ -50,7 +49,7 @@
(let* (((key val) kv))
(let-lazy
((symb (string->symbol val))
- (date (date->time-utc (parse-datetime val)))
+ (date (parse-datetime val))
(days (map parse-day-spec (string-split val #\,)))
(num (string->number val))
(nums (map string->number (string-split val #\,))))
diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm
index 507ee08b..640d4747 100644
--- a/module/vulgar/components.scm
+++ b/module/vulgar/components.scm
@@ -4,9 +4,9 @@
#:export ())
(define-public (display-calendar-header! date)
- (let* ((day (number->string (date-day date)))
- (month (number->string (date-month date)))
- (year (number->string (date-year date))))
+ (let* ((day (number->string (day date)))
+ (month (number->string (month date)))
+ (year (number->string (year date))))
;; BSD cal only supports setting highlighted day explicitly for
;; testing the functionality. This seems to at least give me
;; an (almost) working display, albeit ugly.
diff --git a/tests/srfi-19-alt.scm b/tests/srfi-19-alt.scm
new file mode 100644
index 00000000..1fad2fa5
--- /dev/null
+++ b/tests/srfi-19-alt.scm
@@ -0,0 +1,5 @@
+((srfi srfi-19 alt) date+ date- date)
+
+(test-equal #2020-02-28 (date- #2020-03-05 (date day: 6)))
+(test-equal #2020-02-29 (date- #2020-03-05 (date day: 5)))
+(test-equal #2020-03-01 (date- #2020-03-05 (date day: 4)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 20:52:47 +0200