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