diff options
Diffstat (limited to '')
-rwxr-xr-x | code.scm | 38 | ||||
-rwxr-xr-x | main.scm | 11 | ||||
-rw-r--r-- | srfi/srfi-19/util.scm | 55 | ||||
-rw-r--r-- | vcalendar/datetime.scm | 16 |
4 files changed, 76 insertions, 44 deletions
@@ -1,21 +1,16 @@ (define-module (code) - #:export (extract localize-date sort* drop-time! copy-date - drop-time %date<=? date-today? color-if + #:export (extract sort* color-if for-each-in STR-YELLOW STR-RESET print-vcomponent)) (use-modules (srfi srfi-19) - (srfi srfi-19 setters) + (srfi srfi-19 util) (srfi srfi-26) (vcalendar)) (define (extract field) (cut get-attr <> field)) -(define (localize-date date) - (time-utc->date (date->time-utc date) - (date-zone-offset (current-date)))) - ;;; This function borrowed from web-ics (calendar util) (define* (sort* items comperator #:optional (get identity)) "A sort function more in line with how python's sorted works" @@ -26,35 +21,6 @@ (define STR-YELLOW "\x1b[0;33m") (define STR-RESET "\x1b[m") -(define (drop-time! date) - (set! (hour date) 0) - (set! (minute date) 0) - (set! (second date) 0) - (set! (nanosecond date) 0) - date) - -(define (copy-date date) - (let* ((date-type (@@ (srfi srfi-19) date)) - (access (lambda (field) ((record-accessor date-type field) date)))) - (apply make-date (map access (record-type-fields date-type))))) - -(define (drop-time date) - (let ((new-date (copy-date date))) - (drop-time! new-date))) - -(define (%date<=? a b) - (time<=? (date->time-utc a) - (date->time-utc b))) - -(define (date-today? input-date) - (let* ((date (current-date)) - (now (drop-time date)) - (then (copy-date now))) - (set! (day then) - (1+ (day then))) - (and (%date<=? now input-date) - (%date<=? input-date then)))) - (define-syntax-rule (color-if pred color body ...) (let ((pred-value pred)) @@ -6,8 +6,10 @@ (use-modules (srfi srfi-1) (srfi srfi-19) + (srfi srfi-19 util) (srfi srfi-26) (vcalendar) + (vcalendar datetime) (code)) ;;; ------------------------------------------------------------ @@ -16,14 +18,7 @@ ;;; Parse all start times into scheme date objects. (for-each-in (children cal 'VEVENT) (cut transform-attr! <> "DTSTART" - (lambda (start) - (localize-date - (string->date - start - (case (string-length start) - ((8) "~Y~m~d") - ((15) "~Y~m~dT~H~M~S") - ((16) "~Y~m~dT~H~M~S~z")))))))) + parse-datetime))) (define (search cal term) (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) diff --git a/srfi/srfi-19/util.scm b/srfi/srfi-19/util.scm new file mode 100644 index 00000000..777f39f2 --- /dev/null +++ b/srfi/srfi-19/util.scm @@ -0,0 +1,55 @@ +(define-module (srfi srfi-19 util) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 setters) + #:export (copy-date + drop-time! drop-time + localize-date + date-today?)) + +(define (copy-date date) + "Returns a copy of the given date structure" + (let* ((date-type (@@ (srfi srfi-19) date)) + (access (lambda (field) ((record-accessor date-type field) date)))) + (apply make-date (map access (record-type-fields date-type))))) + +(define (drop-time! date) + "Sets the hour, minute, second and nanosecond attribute of date to 0." + (set! (hour date) 0) + (set! (minute date) 0) + (set! (second date) 0) + (set! (nanosecond date) 0) + date) + +(define (drop-time date) + "Returns a copy of date; with the hour, minute, second and nanosecond +attribute set to 0." + #; + (let ((new-date (copy-date date))) ; + (drop-time! new-date)) + (set-fields date + ((date-hour) 0) + ((date-minute) 0) + ((date-second) 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 +(current-date)." + (time-utc->date (date->time-utc date) + (date-zone-offset (current-date)))) + +(define (date-today? input-date) + (let* ((date (current-date)) + (now (drop-time date)) + (then (copy-date now))) + (set! (day then) + (1+ (day then))) + (and (%date<=? now input-date) + (%date<=? input-date then)))) diff --git a/vcalendar/datetime.scm b/vcalendar/datetime.scm new file mode 100644 index 00000000..af8382c8 --- /dev/null +++ b/vcalendar/datetime.scm @@ -0,0 +1,16 @@ +(define-module (vcalendar datetime) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) + + #:export (parse-datetime) + ) + +(define (parse-datetime dtime) + "Parse the given date[time] string into a date object." + (localize-date + (string->date + dtime + (case (string-length dtime) + ((8) "~Y~m~d") + ((15) "~Y~m~dT~H~M~S") + ((16) "~Y~m~dT~H~M~S~z"))))) |