blob: 777f39f28bd3d54c2eb1391a100b4e3deb649b16 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
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))))
|
