blob: af1d95d5e14e6feb7320bb0cff463774c6e7a38e (
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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
(define-module (vcomponent duration)
:use-module (hnh util)
:use-module (hnh util exceptions)
:use-module (hnh util object)
:use-module (hnh util type)
:use-module (datetime)
:use-module (ice-9 peg)
:use-module (ice-9 match)
:use-module (srfi srfi-1)
:export (duration
parse-duration
format-duration
))
(define-type (duration-week)
(duration-week-sign keyword: sign type: (memv '(+ -)))
(duration-week-count keyword: week type: integer?))
(define-type (duration-datetime)
(duration-datetime-sign keyword: sign type: (memv '(+ -)))
(duration-day keyword: day default: #f
type: (or false? integer?))
(duration-time keyword: time default: #f
type: (or false? time?)))
(define (duration? x)
(or (duration-week? x)
(duration-datetime? x)))
(define (duration-sign duration)
(typecheck duration duration?)
((cond ((duration-week? duration) duration-week-sign)
((duration-datetime? duration) duration-datetime-sign))
duration))
(define* (duration
key: (sign '+)
week day time)
(when (and week (or day time))
(scm-error 'misc-error "duration"
"Can't give week together with day or time"
#f #f))
(if week
(duration-week sign: sign week: week)
(duration-datetime
sign: sign
day: day
time: time)))
(define (format-duration duration)
(with-output-to-string
(lambda ()
(unless (eq? '+ (duration-sign duration))
(display (duration-sign duration)))
(display "P")
(cond ((duration-week? duration)
(format #t "~aW" (duration-week-count duration)))
((duration-datetime? duration)
(awhen (duration-day duration) (format #t "~aD" it))
(awhen (duration-time duration)
(display "T")
;; if any non-zero,
(unless (= 0 (hour it) (minute it) (second it))
(format #t "~aH" (hour it))
(unless (= 0 (minute it) (second it))
(format #t "~aM" (minute it))
(unless (= 0 (second it))
(format #t "~aS" (second it)))))))))))
(define-peg-pattern number all (+ (range #\0 #\9)))
(define-peg-pattern time-pattern body
(and (ignore "T")
(and (? (capture (and number "H")))
(? (and (? (capture (and number "M")))
(? (capture (and number "S"))))))))
(define-peg-pattern dur-pattern body
(and (capture (? (or "+" "-")))
(and "P"
(or (capture (and number "W"))
(or (capture (and (and number "D")
(? time-pattern)))
(capture time-pattern))))))
(define (parse-duration str)
(let ((m (match-pattern dur-pattern str)))
(unless m
(scm-error 'parse-error "parse-duration"
"~s doesn't appar to be a duration"
(list str)
#f))
(unless (= (peg:end m) (string-length str))
(warning "Garbage at end of duration"))
(let* ((tree (peg:tree m))
(sign (case (string->symbol (car tree))
[(+ -) => identity]
[(P) '+]))
(lst (concatenate
(map (match-lambda
[(('number num) type)
(let ((n (string->number num)))
(case (string->symbol type)
[(W) `(week: ,n)]
[(D) `(day: ,n)]
[(H) `(hour: ,n)]
[(M) `(minute: ,n)]
[(S) `(second: ,n)]
[else (scm-error 'misc-error "parse-duration"
"Invalid key ~a" type #f)]))]
[a
(scm-error 'misc-error "parse-duration"
"~s not on expected form ((number <num>) type)"
(list a) #f)])
(context-flatten (lambda (x) (and (pair? (car x))
(eq? 'number (caar x))))
(cdr (member "P" tree)))
))))
(apply duration
(cons* sign: sign
(let loop ((rem lst))
(if (null? rem)
'()
;; NOTE a potentially prettier way would be
;; to capture the T above, and use that as
;; the delimiter for the time.
(if (memv (car rem) '(hour: minute: second:))
(list time: (apply time rem))
(cons* (car rem) (cadr rem)
(loop (cddr rem)))))))))))
|
