diff options
| -rw-r--r-- | code.scm | 3 | ||||
| -rwxr-xr-x | main.scm | 13 | ||||
| -rw-r--r-- | srfi/srfi-19/util.scm | 21 | ||||
| -rwxr-xr-x | test.scm | 15 | ||||
| -rw-r--r-- | util.scm | 6 | ||||
| -rw-r--r-- | vcalendar.scm | 49 | ||||
| -rw-r--r-- | vcalendar/datetime.scm | 4 | ||||
| -rw-r--r-- | vcalendar/recur.scm | 17 |
8 files changed, 83 insertions, 45 deletions
@@ -29,9 +29,6 @@ (begin body ...) (if pred-value STR-RESET "")))) -(define-syntax-rule (for-each-in lst proc) - (for-each proc lst)) - (define* (print-vcomponent comp #:optional (depth 0)) (let ((kvs (map (lambda (key) (cons key (get-attr comp key))) @@ -9,16 +9,11 @@ (srfi srfi-19 util) (srfi srfi-26) (vcalendar) - (vcalendar datetime) + (util) (code)) ;;; ------------------------------------------------------------ -(define (parse-dates! cal) -;;; Parse all start times into scheme date objects. - (for-each-in (children cal 'VEVENT) - (cut transform-attr! <> "DTSTART" - parse-datetime))) (define (search cal term) (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) @@ -37,16 +32,14 @@ (define cal (make-vcomponent path)) - (parse-dates! cal) - ;; Sort the events, and print a simple agenda. (for-each-in (sort* (children cal 'VEVENT) - time<? (compose date->time-utc (extract "DTSTART"))) + time<? (extract "DTSTART")) (lambda (ev) (format #t "~a | ~a~%" (let ((start (get-attr ev "DTSTART"))) (color-if (date-today? start) STR-YELLOW - (date->string start "~1 ~H:~M"))) + (date->string (time-utc->date start) "~1 ~H:~M"))) (get-attr ev "SUMMARY"))))) diff --git a/srfi/srfi-19/util.scm b/srfi/srfi-19/util.scm index a020ae55..ab951ea4 100644 --- a/srfi/srfi-19/util.scm +++ b/srfi/srfi-19/util.scm @@ -7,8 +7,11 @@ localize-date date-today? seconds minutes hours days weeks - date-add)) + date-add + time-add + time->string)) +#; (define (copy-date date) "Returns a copy of the given date structure" (let* ((date-type (@@ (srfi srfi-19) date)) @@ -36,10 +39,12 @@ attribute set to 0." ((date-nanosecond) 0))) +#; (define (%date<=? a b) (time<=? (date->time-utc a) (date->time-utc b))) +#; (define (localize-date date) "Returns a <date> object representing the same datetime as `date`, but transposed to the current timezone. Current timezone gotten from @@ -47,6 +52,13 @@ transposed to the current timezone. Current timezone gotten from (time-utc->date (date->time-utc date) (date-zone-offset (current-date)))) +(define (today? time) + (let* ((now (current-date)) + (then (add-duration time (make-time time-difference 0 (* 24 3600))))) + (and (time<=? time now) + (time<=? now then)))) + + #; (define (date-today? input-date) (let* ((date (current-date)) (now (drop-time date)) @@ -62,6 +74,13 @@ transposed to the current timezone. Current timezone gotten from (define days (* 24 hours)) (define weeks (* 7 days)) +(define (time-add time amount unit) + (add-duration time (make-time time-duration 0 (* amount unit)))) + +#; (define (date-add date amount unit) (time-utc->date (add-duration (date->time-utc date) (make-time time-duration 0 (* amount unit))))) + +(define* (time->string time #:optional (format "~c")) + (date->string (time-utc->date time) format)) @@ -6,11 +6,11 @@ (use-modules (rnrs base) ; assert (srfi srfi-1) (srfi srfi-19) + (srfi srfi-19 util) (srfi srfi-41) (code) (vcalendar) - (vcalendar recur) - (vcalendar datetime)) + (vcalendar recur)) (define cal (make-vcomponent "testcal/repeating-event.ics")) @@ -22,16 +22,15 @@ (assert (equal? (children ev) (children ev-copy))) -(transform-attr! ev "DTSTART" parse-datetime) - - (stream-for-each (lambda (ev) - (display (date->string (attr ev "DTSTART") "~1 ~3")) (newline)) + (format #t "~a -- ~a~%" + (time->string (attr ev "DTSTART") "~1 ~3") + (time->string (attr ev "DTEND") "~1 ~3"))) (stream-take 10 (recur-event ev))) (define stream-cadr (compose stream-car stream-cdr)) (newline) -(display (date->string (attr ev "DTSTART") "~1 ~3")) (newline) -(display (date->string (attr (stream-cadr (recur-event ev)) "DTSTART") "~1 ~3")) (newline) +(display (time->string (attr ev "DTSTART") "~1 ~3")) (newline) +(display (time->string (attr (stream-cadr (recur-event ev)) "DTSTART") "~1 ~3")) (newline) @@ -1,6 +1,7 @@ (define-module (util) #:use-module (srfi srfi-1) - #:export (destructure-lambda let-multi fold-lists catch-let) + #:export (destructure-lambda let-multi fold-lists catch-let + for-each-in) ) (define-public upstring->symbol (compose string->symbol string-upcase)) @@ -43,3 +44,6 @@ ((type) (apply handler err args)) ... (else (format #t "Unhandled error type ~a, rethrowing ~%" err) (apply throw err args)))))))) + +(define-syntax-rule (for-each-in lst proc) + (for-each proc lst)) diff --git a/vcalendar.scm b/vcalendar.scm index 1bf0a1bb..03817957 100644 --- a/vcalendar.scm +++ b/vcalendar.scm @@ -1,27 +1,38 @@ (define-module (vcalendar) #:use-module (vcalendar primitive) + #:use-module (vcalendar datetime) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26)) + #:use-module (srfi srfi-26) + #:use-module (util)) + +(define (parse-dates! cal) +;;; Parse all start times into scheme date objects. + (for-each-in (children cal 'VEVENT) + (lambda (ev) + (transform-attr! ev "DTSTART" parse-datetime) + (transform-attr! ev "DTEND" parse-datetime))) + cal) (define-public (make-vcomponent path) - (if (string-ci=? ".ics" (string-take-right path 4)) - ;; == Single ICS file == - ;; Remove the abstract ROOT component, - ;; returning the wanted VCALENDAR component - (car (%vcomponent-children - (%vcomponent-make path))) - ;; == Assume vdir == - ;; Also removes the abstract ROOT component, but also - ;; merges all VCALENDAR's children into the first - ;; VCALENDAR, and return that VCALENDAR. - ;; - ;; TODO the other VCALENDAR components might not get thrown away, - ;; this since I protect them from the GC in the C code. - (reduce (lambda (cal accum) - (for-each (cut %vcomponent-push-child! accum <>) - (%vcomponent-children cal)) - accum) - '() (%vcomponent-children (%vcomponent-make path))))) + (parse-dates! + (if (string-ci=? ".ics" (string-take-right path 4)) + ;; == Single ICS file == + ;; Remove the abstract ROOT component, + ;; returning the wanted VCALENDAR component + (car (%vcomponent-children + (%vcomponent-make path))) + ;; == Assume vdir == + ;; Also removes the abstract ROOT component, but also + ;; merges all VCALENDAR's children into the first + ;; VCALENDAR, and return that VCALENDAR. + ;; + ;; TODO the other VCALENDAR components might not get thrown away, + ;; this since I protect them from the GC in the C code. + (reduce (lambda (cal accum) + (for-each (cut %vcomponent-push-child! accum <>) + (%vcomponent-children cal)) + accum) + '() (%vcomponent-children (%vcomponent-make path)))))) (define-public (type-filter t lst) (filter (lambda (e) (eqv? t (type e))) diff --git a/vcalendar/datetime.scm b/vcalendar/datetime.scm index af8382c8..9f47f5c3 100644 --- a/vcalendar/datetime.scm +++ b/vcalendar/datetime.scm @@ -7,7 +7,9 @@ (define (parse-datetime dtime) "Parse the given date[time] string into a date object." - (localize-date + ;; localize-date + + (date->time-utc (string->date dtime (case (string-length dtime) diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm index a480d946..23c00b12 100644 --- a/vcalendar/recur.scm +++ b/vcalendar/recur.scm @@ -126,9 +126,17 @@ (match rule (($ <recur-rule> freq until count interval bysecond byminute byhour wkst) (case freq - ((WEEKLY) (transform-attr! new-event "DTSTART" (cut date-add <> 1 weeks)) + ((WEEKLY) + (transform-attr! new-event "DTSTART" (cut time-add <> 1 weeks)) + (set! (attr new-event "DTEND") + (add-duration (attr new-event "DTSTART") + (attr new-event "DURATION"))) (values new-event rule)) - ((DAILY) (transform-attr! new-event "DTSTART" (cut date-add <> 1 days)) + ((DAILY) + (transform-attr! new-event "DTSTART" (cut time-add <> 1 days)) + (set! (attr new-event "DTEND") + (add-duration (attr new-event "DTSTART") + (attr new-event "DURATION"))) (values new-event rule)) (else (values '() rule)))) (_ (values event rule))))) @@ -142,6 +150,11 @@ (recur-event-stream next-event next-rule))))) (define (recur-event event) + (unless (attr event "DURATION") + (set! (attr event "DURATION") + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) (recur-event-stream event (build-recur-rules (get-attr event "RRULE")))) (define tzero (make-time time-utc 0 0)) |