diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-11-04 17:08:38 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-11-05 11:21:25 +0100 |
commit | 4080b0c7e97acb7357a7ab85589b324e382e0d47 (patch) | |
tree | 3ed5e38c94ee306311d497cda397cab38d173e73 /module | |
parent | Further cleanup in (vcomponent). (diff) | |
download | calp-4080b0c7e97acb7357a7ab85589b324e382e0d47.tar.gz calp-4080b0c7e97acb7357a7ab85589b324e382e0d47.tar.xz |
Add let-env.
Diffstat (limited to 'module')
-rw-r--r-- | module/util.scm | 16 | ||||
-rw-r--r-- | module/vcomponent.scm | 58 | ||||
-rw-r--r-- | module/vcomponent/recurrence/generate.scm | 11 |
3 files changed, 43 insertions, 42 deletions
diff --git a/module/util.scm b/module/util.scm index 707cba90..0d4d20d6 100644 --- a/module/util.scm +++ b/module/util.scm @@ -12,7 +12,7 @@ re-export-modules use-modules* -> set aif - tree-map let-lazy) + tree-map let-lazy let-env) #:replace (let* set! define-syntax when unless if)) @@ -374,3 +374,17 @@ [(set (acc obj) = (op rest ...)) (set-fields obj ((acc) (op (acc obj) rest ...)))])) + + + +;; TODO multiple values +(define-syntax let-env + (syntax-rules () + [(_ ((name value)) + body ...) + (let ((sname (symbol->string (quote name)))) + (let ((ogenv (getenv sname))) + (setenv sname value) + (let ((return (begin body ...))) + (setenv sname ogenv) + return)))])) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index c1ee0e23..bda9d58c 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -23,42 +23,36 @@ "Parse all start times into scheme date objects." (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal)) - (let ((tz (getenv "TZ"))) - (aif (prop (attr* ev 'DTSTART) 'TZID) - (setenv "TZ" (car it)) - (unsetenv "TZ")) - (let* - ((dptr (attr* ev 'DTSTART)) - (eptr (attr* ev 'DTEND)) + (let-env ((TZ (and=> (prop (attr* ev 'DTSTART) 'TZID) car))) + (let* + ((dptr (attr* ev 'DTSTART)) + (eptr (attr* ev 'DTEND)) - (date (parse-datetime (value dptr))) - (end-date - (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] - [(not eptr) - (let ((d (set (date-hour date) = (+ 1)))) - (set! (attr ev 'DTEND) d - eptr (attr* ev 'DTEND)) - d)] - [(value eptr) => parse-datetime] - [else - (set (date-hour date) = (+ 1))]))) + (date (parse-datetime (value dptr))) + (end-date + (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] + [(not eptr) + (let ((d (set (date-hour date) = (+ 1)))) + (set! (attr ev 'DTEND) d + eptr (attr* ev 'DTEND)) + d)] + [(value eptr) => parse-datetime] + [else + (set (date-hour date) = (+ 1))]))) - (set! (value dptr) (date->time-utc date) - (value eptr) (date->time-utc end-date)) + (set! (value dptr) (date->time-utc date) + (value eptr) (date->time-utc end-date)) - (when (prop (attr* ev 'DTSTART) 'TZID) - ;; Re-align date to have correect timezone. This is since time->date gives - ;; correct, but the code above may (?) fail to update the timezone. - (set! (zone-offset date) (zone-offset (time-utc->date (value dptr))) - (value dptr) (date->time-utc date) + (when (prop (attr* ev 'DTSTART) 'TZID) + ;; Re-align date to have correect timezone. This is since time->date gives + ;; correct, but the code above may (?) fail to update the timezone. + (set! (zone-offset date) (zone-offset (time-utc->date (value dptr))) + (value dptr) (date->time-utc date) - ;; The standard says that DTEND must have the same - ;; timezone as DTSTART. Here we trust that blindly. - (zone-offset end-date) (zone-offset date) - (value eptr) (date->time-utc end-date)))) - - - (setenv "TZ" tz)))) + ;; The standard says that DTEND must have the same + ;; timezone as DTSTART. Here we trust that blindly. + (zone-offset end-date) (zone-offset date) + (value eptr) (date->time-utc end-date))))))) (define* (parse-calendar path) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 50ce83e5..3988141c 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -44,13 +44,8 @@ ;; Specifically, 23h or 25h when going between summer and "normal" time. (define (next-event ev r) - (let ((e (copy-vcomponent ev)) - (tz (getenv "TZ"))) - ;; (setenv "TZ" (car (prop (attr* e 'DTSTART) 'TZID))) - (aif (prop (attr* e 'DTSTART) 'TZID) - (setenv "TZ" (car it)) - ;; Should missing be this, or explicitly GMT? - (unsetenv "TZ")) + (let ((e (copy-vcomponent ev))) + (let-env ((TZ (and=> (prop (attr* e 'DTSTART) 'TZID) car)))) (let ((d (time-utc->date (attr e 'DTSTART))) (i (interval r))) @@ -72,8 +67,6 @@ (set! (attr e 'DTEND) (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) - (setenv "TZ" tz) - e)) #; |