1#lang typed/racket/base
2
3(require racket/match
4         racket/math
5         (prefix-in srfi-date: "typed-srfi19.rkt")
6         "type-doc.rkt"
7         "math.rkt"
8         "format.rkt")
9
10(provide (all-defined-out))
11
12(require/typed
13 db
14 [#:struct sql-date ([year : Integer]
15                     [month : Byte]
16                     [day : Byte])]
17 [#:struct sql-time ([hour : Natural]
18                     [minute : Natural]
19                     [second : Natural]
20                     [nanosecond : Natural]
21                     [tz : (U Integer #f)])]
22 [#:struct sql-timestamp ([year : Integer]
23                          [month : Natural]
24                          [day : Natural]
25                          [hour : Natural]
26                          [minute : Natural]
27                          [second : Natural]
28                          [nanosecond : Natural]
29                          [tz : (U Integer #f)])])
30
31(require/typed
32 racket/base
33 [#:struct date ([second : Byte]
34                 [minute : Byte]
35                 [hour : Byte]
36                 [day : Positive-Byte]
37                 [month : Positive-Byte]
38                 [year : Integer]
39                 [week-day : Byte]
40                 [year-day : Index]
41                 [dst? : Boolean]
42                 [time-zone-offset : Integer])
43           #:extra-constructor-name make-date]
44 [#:struct (date* date) ([nanosecond : Nonnegative-Fixnum]
45                         [time-zone-name : String])
46           #:extra-constructor-name make-date*]
47 [seconds->date  (->* [Real] [Any] date*)]
48 )
49
50(require/typed
51 racket/date
52 [current-date  (-> date*)]
53 [date->string  (->* [date] [Any] String)]
54 [date-display-format  (-> (U 'american
55                              'chinese
56                              'german
57                              'indian
58                              'irish
59                              'iso-8601
60                              'rfc2822
61                              'julian))]
62 [date->seconds  (->* [date] [Any] Integer)]
63 [date*->seconds  (->* [date] [Any] Real)])
64
65(define seconds-per-minute 60)
66(define seconds-per-hour (* 60 seconds-per-minute))
67(define seconds-per-day (* 24 seconds-per-hour))
68(define seconds-per-week (* 7 seconds-per-day))
69(define avg-seconds-per-year (* #e365.2425 seconds-per-day))
70(define avg-seconds-per-month (* 1/12 avg-seconds-per-year))
71
72;; ===================================================================================================
73;; UTC dates for plotting
74
75;; A date is always represented by the number of seconds since the platform-specific, UTC epoch
76
77(: date*->utc-seconds (-> date Real))
78(define (date*->utc-seconds dt)
79  (- (date*->seconds dt #f) (date-time-zone-offset dt)))
80
81(: date->utc-seconds (-> date Real))
82(define (date->utc-seconds dt)
83  (- (date->seconds dt #f) (date-time-zone-offset dt)))
84
85(: utc-seconds-second (-> Real Real))
86(define (utc-seconds-second secs)
87  (define w (floor secs))
88  (define f (- secs w))
89  (+ f (date-second (seconds->date w #f))))
90
91(: utc-seconds-round-year (-> Real Integer))
92(define (utc-seconds-round-year secs)
93  (define dt (seconds->date secs #f))
94  (define y1 (date-year dt))
95  ;; Find start of this year, start of next year, and difference between them in UTC seconds
96  (define s1 (date->seconds (date 0 0 0 1 1 y1 0 0 #f 0) #f))
97  (define s2 (date->seconds (date 0 0 0 1 1 (+ y1 1) 0 0 #f 0) #f))
98  (define diff (- s2 s1))
99  ;; Round by 1) subtracting this year; 2) rounding to this year or next; 3) adding this year
100  (+ (* (exact-round (/ (- secs s1) diff)) diff) s1))
101
102(: utc-seconds-round-month (-> Real Integer))
103(define (utc-seconds-round-month secs)
104  (define dt (seconds->date secs #f))
105  (define m1 (date-month dt))
106  (define y1 (date-year dt))
107  ;; Find start of this month, start of next month, and difference between them in UTC seconds
108  (define s1 (date->seconds (date 0 0 0 1 m1 y1 0 0 #f 0) #f))
109  (define-values (m2 y2)
110    (let ([m2  (+ m1 1)])
111      (cond [(m2 . > . 12)  (values 1 (+ y1 1))]
112            [else           (values m2 y1)])))
113  (define s2 (date->seconds (date 0 0 0 1 m2 y2 0 0 #f 0) #f))
114  (define diff (- s2 s1))
115  ;; Round by 1) subtracting this month; 2) rounding to this month or next; 3) adding this month
116  (+ (* (exact-round (/ (- secs s1) diff)) diff) s1))
117
118;; ===================================================================================================
119;; Time
120
121;; A date-independent representation of time
122
123(struct plot-time ([second : Nonnegative-Exact-Rational]
124                   [minute : Byte]
125                   [hour : Byte]
126                   [day : Integer])
127  #:transparent)
128
129(:: seconds->plot-time (-> Real plot-time))
130(define (seconds->plot-time s)
131  (let* ([s  (inexact->exact s)]
132         [day  (exact-floor (/ s seconds-per-day))]
133         [s  (- s (* day seconds-per-day))]
134         [hour  (exact-floor (/ s seconds-per-hour))]
135         [s  (- s (* hour seconds-per-hour))]
136         [minute  (exact-floor (/ s seconds-per-minute))]
137         [s  (- s (* minute seconds-per-minute))])
138    (plot-time (max 0 s)
139               (assert (max 0 (min 59 minute)) byte?)
140               (assert (max 0 (min 23 hour)) byte?)
141               day)))
142
143(:: plot-time->seconds (-> plot-time Exact-Rational))
144(define (plot-time->seconds t)
145  (match-define (plot-time second minute hour day) t)
146  (+ second
147     (* minute seconds-per-minute)
148     (* hour seconds-per-hour)
149     (* day seconds-per-day)))
150
151(: sql-date->date* (-> sql-date date*))
152(define (sql-date->date* x)
153  (match-define (sql-date y m d) x)
154  (if (or (zero? m) (zero? d))
155      (raise-argument-error 'sql-date->date* "complete sql-date" x)
156      (date* 0 0 0 d m y 0 0 #t 0 0 "UTC")))
157
158(: sql-time->plot-time (-> sql-time plot-time))
159(define (sql-time->plot-time x)
160  (match-define (sql-time h m s ns tz) x)
161  (cond [(and (<= 0 m 59)
162              (<= 0 h 23))
163         (seconds->plot-time
164          (- (plot-time->seconds
165              (plot-time (+ s (/ ns 1000000000)) (assert m byte?) (assert h byte?) 0))
166             (if tz tz 0)))]
167        [else
168         (raise-argument-error 'sql-time->plot-time "valid sql-time" x)]))
169
170(: sql-timestamp->date* (-> sql-timestamp date*))
171(define (sql-timestamp->date* x)
172  (match-define (sql-timestamp y m d h mn s ns tz) x)
173  (cond [(or (zero? m) (zero? d))
174         (raise-argument-error 'sql-timestamp->date* "complete sql-timestamp" x)]
175        [(and (<= 0 s 60)  ; leap seconds
176              (<= 0 mn 59)
177              (<= 0 h 23)
178              (<= 1 d 31)
179              (<= 1 m 12))
180         (date* (assert s byte?) (assert mn byte?) (assert h byte?)
181                (assert d byte?) (assert m byte?) (assert y byte?)
182                0 0 #t (if tz tz 0) (assert ns fixnum?) "UTC")]
183        [else
184         (raise-argument-error 'sql-timestamp->date* "valid sql-timestamp" x)]))
185
186(:: datetime->real (-> (U plot-time date date* sql-date sql-time sql-timestamp) Real))
187(define (datetime->real x)
188  (cond [(plot-time? x)      (plot-time->seconds x)]
189        [(date*? x)          (date*->utc-seconds x)]
190        [(date? x)           (date->utc-seconds x)]
191        [(sql-date? x)       (date*->utc-seconds (sql-date->date* x))]
192        [(sql-time? x)       (plot-time->seconds (sql-time->plot-time x))]
193        [(sql-timestamp? x)  (date*->utc-seconds (sql-timestamp->date* x))]))
194
195;; ===================================================================================================
196;; Formatting following SRFI 19, with alterations
197
198#|
199Supported format specifiers:
200
201~a  locale's abbreviated weekday name (Sun...Sat)
202~A  locale's full weekday name (Sunday...Saturday)
203~b  locale's abbreviate month name (Jan...Dec)
204~B  locale's full month day (January...December)
205~d  day of month, zero padded (01...31)
206~D  date (mm/dd/yy)
207~e  day of month, blank padded ( 1...31)
208~h  same as ~b
209~H  hour, zero padded, 24-hour clock (00...23)
210~I  hour, zero padded, 12-hour clock (01...12)
211~j  day of year, zero padded
212~k  hour, blank padded, 24-hour clock (00...23)
213~l  hour, blank padded, 12-hour clock (01...12)
214~m  month, zero padded (01...12)
215~M  minute, zero padded (00...59)
216~N  nanosecond, zero padded
217~p  locale's AM or PM
218~r  time, 12 hour clock, same as "~I:~M:~S ~p"
219~S  second, zero padded (00...60)
220~f  seconds+fractional seconds, using locale's decimal separator (e.g. 5.2).
221~s  number of full seconds since "the epoch" (in UTC)
222~T  time, 24 hour clock, same as "~H:~M:~S"
223~U  week number of year with Sunday as first day of week (00...53)
224~V  week number of year with Monday as first day of week (01...52)
225~w  day of week (0...6)
226~W  week number of year with Monday as first day of week (01...52)
227~x  week number of year with Monday as first day of week (00...53)
228~X  locale's date representation, for example: "07/31/00"
229~y  last two digits of year (00...99)
230~Y  year
231~1  ISO-8601 year-month-day format
232~3  ISO-8601 hour-minute-second format
233~5  ISO-8601 year-month-day-hour-minute-second format
234|#
235
236(: plot-date-formatter (-> Real Real (-> Symbol Real (U String #f))))
237(define (plot-date-formatter x-min x-max)
238  (define digits (digits-for-range x-min x-max))
239  (λ (fmt secs)
240    (case fmt
241      [(~f)  (define s (utc-seconds-second secs))
242             (define str (real->string/trunc s (max 0 digits)))
243             (if (s . < . 10) (format "0~a" str) str)]
244      [(~s)  (real->plot-label secs digits)]
245      [(~a ~A ~b ~B ~d ~D ~e ~h ~H ~I ~j ~k ~l ~m ~M ~N
246           ~p ~r ~S ~f ~s ~T ~U ~V ~w ~W ~x ~X ~y ~Y ~1 ~3 ~5)
247       (match-define (date* s mn h d m y _wd _yd _dst? tz ns _tz-name) (seconds->date secs #f))
248       (srfi-date:date->string (srfi-date:make-date ns s mn h d m y tz) (symbol->string fmt))]
249      [else  #f])))
250
251#|
252Supported format specifiers:
253
254~d  day
255~H  hour, zero padded, 24-hour clock (00...23)
256~I  hour, zero padded, 12-hour clock (01...12)
257~k  hour, blank padded, 24-hour clock ( 0...23)
258~l  hour, blank padded, 12-hour clock ( 1...12)
259~p  locale's AM or PM
260~M  minute, zero padded (00...59)
261~S  second, zero padded (00...60)
262~f  seconds+fractional seconds, using locale's decimal separator (e.g. 5.2).
263~s  second, formatted (nanoseconds, etc.)
264~r  time, 12 hour clock, same as "~I:~M:~S ~p"
265~T  time, 24 hour clock, same as "~H:~M:~S"
266~3  ISO-8601 hour-minute-second format
267|#
268
269(: plot-time-formatter (-> Real Real (-> Symbol Real (U String #f))))
270(define (plot-time-formatter x-min x-max)
271  (define digits (digits-for-range x-min x-max))
272  (λ (fmt secs)
273    (case fmt
274      [(~H ~I ~k ~l ~p ~M ~S ~f ~s ~r ~T ~3)
275       ((plot-date-formatter x-min x-max) fmt (real-modulo secs seconds-per-day))]
276      [(~d)  (define digits (digits-for-range (/ x-min seconds-per-day) (/ x-max seconds-per-day)))
277             (real->plot-label (plot-time-day (seconds->plot-time secs)) digits)]
278      [else  #f])))
279