diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2020-01-24 20:21:41 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2020-01-24 20:23:04 +0100 |
commit | e822f7b81245c919eda8bd8ad4b482df075e0508 (patch) | |
tree | 3024a9a1a80e5c9ffd6d187a028c783dc4b7abbd | |
parent | Extend define-many to allow a custom define procedure. (diff) | |
download | calp-e822f7b81245c919eda8bd8ad4b482df075e0508.tar.gz calp-e822f7b81245c919eda8bd8ad4b482df075e0508.tar.xz |
Start of new date structures.
-rw-r--r-- | module/entry-points/ical.scm | 8 | ||||
-rw-r--r-- | module/entry-points/terminal.scm | 9 | ||||
-rw-r--r-- | module/output/ical.scm | 4 | ||||
-rw-r--r-- | module/output/terminal.scm | 31 | ||||
-rw-r--r-- | module/srfi/srfi-19/alt.scm | 348 | ||||
-rw-r--r-- | module/srfi/srfi-19/alt/util.scm | 107 | ||||
-rw-r--r-- | module/srfi/srfi-19/util.scm | 28 | ||||
-rw-r--r-- | module/vcomponent/datetime.scm | 25 | ||||
-rw-r--r-- | module/vcomponent/group.scm | 4 | ||||
-rw-r--r-- | module/vcomponent/load.scm | 6 | ||||
-rw-r--r-- | module/vcomponent/parse.scm | 36 | ||||
-rw-r--r-- | module/vcomponent/recurrence/parse.scm | 7 | ||||
-rw-r--r-- | module/vulgar/components.scm | 6 | ||||
-rw-r--r-- | tests/srfi-19-alt.scm | 5 |
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))) |