From 2994bef5120d9425c42beb0dfe3f568e80c9771f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 Mar 2019 15:34:41 +0100 Subject: Fix setters for date types. --- code.scm | 46 +++++++++++++++++++++++++++++++--------------- 1 file changed, 31 insertions(+), 15 deletions(-) (limited to 'code.scm') diff --git a/code.scm b/code.scm index bbfc6e9a..eba732bc 100755 --- a/code.scm +++ b/code.scm @@ -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 ...) -- cgit v1.2.3