diff options
Diffstat (limited to '')
-rwxr-xr-x | code.scm | 46 | ||||
-rwxr-xr-x | main.scm | 10 | ||||
-rw-r--r-- | srfi/srfi-19/setters.scm | 15 |
3 files changed, 51 insertions, 20 deletions
@@ -1,6 +1,10 @@ -(add-to-load-path (dirname (current-filename))) +(define-module (code) + #:export (extract localize-date sort* drop-time! copy-date + drop-time %date<=? date-today? color-if + for-each-in STR-YELLOW STR-RESET)) (use-modules (srfi srfi-19) + (srfi srfi-19 setters) (srfi srfi-26) (vcalendar)) @@ -21,22 +25,34 @@ (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 (make-date 0 0 0 0 - (date-day date) - (date-month date) - (date-year date) - (date-zone-offset date))) - (then (make-date 0 0 0 0 - (1+ (date-day date)) - (date-month date) - (date-year date) - (date-zone-offset date)))) - (and (time<=? (date->time-utc now) - (date->time-utc input-date)) - (time<=? (date->time-utc input-date) - (date->time-utc then))))) + (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 ...) @@ -4,11 +4,11 @@ (add-to-load-path ".") -(load "code.scm") (use-modules (srfi srfi-1) (srfi srfi-19) (srfi srfi-26) - (vcalendar)) + (vcalendar) + (code)) ;;; ------------------------------------------------------------ @@ -29,8 +29,9 @@ (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev))) (children cal)))) (find (lambda (ev) (string-contains-ci (car ev) term)) - (map-cons (cut get-attr <> "SUMMARY") - events))))) + (map cons (map (cut get-attr <> "SUMMARY") + events) + events))))) (define (main args) @@ -54,5 +55,4 @@ (get-attr ev "SUMMARY"))))) -k #; (define pizza-event (search cal "pizza")) diff --git a/srfi/srfi-19/setters.scm b/srfi/srfi-19/setters.scm new file mode 100644 index 00000000..147cb6c0 --- /dev/null +++ b/srfi/srfi-19/setters.scm @@ -0,0 +1,15 @@ +(define-module (srfi srfi-19 setters) + #:use-module (srfi srfi-19) ; Date/Time + ;; (record-type-fields (@@ (srfi srfi-19) date)) + #:export (nanosecond second minute hour day month year zone-offset)) + + +(define nanosecond (make-procedure-with-setter (@ (srfi srfi-19) date-nanosecond) (@@ (srfi srfi-19) set-date-nanosecond!))) +(define second (make-procedure-with-setter (@ (srfi srfi-19) date-second) (@@ (srfi srfi-19) set-date-second!))) +(define minute (make-procedure-with-setter (@ (srfi srfi-19) date-minute) (@@ (srfi srfi-19) set-date-minute!))) +(define hour (make-procedure-with-setter (@ (srfi srfi-19) date-hour) (@@ (srfi srfi-19) set-date-hour!))) +(define day (make-procedure-with-setter (@ (srfi srfi-19) date-day) (@@ (srfi srfi-19) set-date-day!))) +(define month (make-procedure-with-setter (@ (srfi srfi-19) date-month) (@@ (srfi srfi-19) set-date-month!))) +(define year (make-procedure-with-setter (@ (srfi srfi-19) date-year) (@@ (srfi srfi-19) set-date-year!))) +(define zone-offset (make-procedure-with-setter (@ (srfi srfi-19) date-zone-offset) (@@ (srfi srfi-19) set-date-zone-offset!))) + |