Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

331 lines (299 sloc) 14.994 kB
#lang typed/racket/base
(require
racket/fixnum
(only-in "format-util.rkt"
localized-message
last-n-digits
padding)
(only-in "datetime.rkt"
Instant Instant? Instant-second
Datetime Datetime? Datetime-offset Datetime-year Datetime-month
Datetime-day Datetime-hour Datetime-minute Datetime-second Datetime-milli
Datetime-year-day
Datetime->InstantUTC
Datetime-week-day year-day days-before-first-week date-week-number))
(define locale-pm 'pm)
(define locale-am 'am)
(define locale-date-time-format 'date-time)
(define locale-short-date-format 'date)
(define locale-time-format 'time)
;; (define tm:iso-8601-date-time-format 'iso8601)
(define locale-number-separator 'separator)
(define locale-abbr-weekday-vector (vector 'sun 'mon 'tue 'wed 'thu 'fri 'sat))
(define locale-long-weekday-vector (vector 'sunday 'monday 'tuesday 'wednesday
'thursday 'friday 'saturday))
;; note empty string in 0th place.
(define locale-abbr-month-vector (vector 'jan 'feb 'mar
'apr 'may 'jun 'jul
'aug 'sep 'oct 'nov
'dec))
(define locale-long-month-vector (vector 'january 'february
'march 'april 'may
'june 'july 'august
'september 'october
'november 'december))
(: locale-am/pm (Integer -> String))
(define (locale-am/pm hr)
(localized-message (if (> hr 11) locale-pm locale-am)))
(: locale-abbr-weekday (Index -> String))
(define (locale-abbr-weekday n)
(localized-message (vector-ref locale-abbr-weekday-vector n)))
(: locale-long-weekday (Index -> String))
(define (locale-long-weekday n)
(localized-message (vector-ref locale-long-weekday-vector n)))
(: locale-abbr-month (Index -> String))
(define (locale-abbr-month n)
(localized-message (vector-ref locale-abbr-month-vector (- n 1))))
(: locale-long-month (Index -> String))
(define (locale-long-month n)
(localized-message (vector-ref locale-long-month-vector (- n 1))))
;; do nothing.
;; Your implementation might want to do something...
(: locale-print-time-zone (Datetime Output-Port -> Void))
(define (locale-print-time-zone date port)
(void))
(: vector-find (String (Vectorof Symbol) (String String -> Boolean) -> (Option Index)))
(define (vector-find needle haystack comparator)
(: len Index)
(define len (vector-length haystack))
(: vector-find-int (Fixnum -> (Option Index)))
(define (vector-find-int index)
(cond
((>= index len) #f)
((comparator needle (localized-message (vector-ref haystack index))) (assert (fx+ index 1) index?))
(else (vector-find-int (fx+ index 1)))))
(vector-find-int 0))
; return a string representing the decimal expansion of the fractional
; portion of a number, limited by a specified precision
(: decimal-expansion (Real Fixnum -> String))
(define (decimal-expansion r precision)
(let: loop : String ([num : Real (- r (round r))]
[p : Fixnum precision])
(if (or (= p 0) (= num 0))
""
(let* ([num-times-10 (* 10 num)]
[round-num-times-10 (round num-times-10)])
(string-append (number->string (inexact->exact round-num-times-10))
(loop (- num-times-10 round-num-times-10) (fx- p 1)))))))
(: locale-abbr-weekday->index (String -> (Option Index)))
(define (locale-abbr-weekday->index string)
(vector-find string locale-abbr-weekday-vector string=?))
(: locale-long-weekday->index (String -> (Option Index)))
(define (locale-long-weekday->index string)
(vector-find string locale-long-weekday-vector string=?))
(: locale-abbr-month->index (String -> (Option Index)))
(define (locale-abbr-month->index string)
(vector-find string locale-abbr-month-vector string=?))
(: locale-long-month->index (String -> (Option Index)))
(define (locale-long-month->index string)
(vector-find string locale-long-month-vector string=?))
(: tz-printer (Integer Output-Port -> Void))
(define (tz-printer offset port)
(display (cond [(= offset 0) "Z"]
[else (let ([sign (cond [(negative? offset) "-"]
[else "+"])]
[hours (abs (quotient offset (* 60 60)))]
[minutes (abs (quotient (remainder offset (* 60 60)) 60))])
(string-append sign
(padding hours #\0 2)
(padding minutes #\0 2)))])
port))
(: date-printer (Datetime Fixnum String Index Output-Port -> Void))
(define (date-printer date index format-string str-len port)
(if (>= index str-len)
(void)
(let ( (current-char (string-ref format-string index)) )
(if (not (char=? current-char #\~))
(begin
(display current-char port)
(date-printer date (fx+ index 1) format-string str-len port))
(if (= (fx+ index 1) str-len) ; bad format string.
(error 'date-printer "bad-date-format-string" format-string)
(let ( (pad-char? (string-ref format-string (fx+ index 1))) )
(cond
((char=? pad-char? #\-)
(if (= (fx+ index 2) str-len) ; bad format string.
(error 'date-printer "bad-date-format-string"
format-string)
(let ( (formatter (get-formatter
(string-ref format-string
(fx+ index 2)))) )
(if (not formatter)
(error 'date-printer "bad-date-format-string" format-string)
(begin
(formatter date #f port)
(date-printer date (fx+ index 3)
format-string str-len port))))))
((char=? pad-char? #\_)
(if (= (fx+ index 2) str-len) ; bad format string.
(error 'date-printer "bad-date-format-string" format-string)
(let ( (formatter (get-formatter
(string-ref format-string
(fx+ index 2)))) )
(if (not formatter)
(error 'date-printer "bad-date-format-string" format-string)
(begin
(formatter date #\Space port)
(date-printer date (fx+ index 3)
format-string str-len port))))))
(else
(let ( (formatter (get-formatter
(string-ref format-string
(fx+ index 1)))) )
(if (not formatter)
(error 'date-printer "bad-date-format-string" format-string)
(begin
(formatter date #\0 port)
(date-printer date (fx+ index 2)
format-string str-len port))))))))))))
(: date->string (Datetime (Option String) -> String))
(define (date->string date format-string)
(let ((format-string (if format-string format-string "~c")))
(unless (string? format-string)
(raise-type-error 'date->string "string" 1 date format-string))
(let ( (str-port (open-output-string)) )
(date-printer date 0 format-string (string-length format-string) str-port)
(get-output-string str-port))))
(define-type DatetimeFormatter (Datetime (Option Char) Output-Port -> Void))
;; A table of output formatting directives.
;; the first time is the format char.
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.
(: directives (Listof (Pair Char DatetimeFormatter)))
(define directives
(list
(cons #\~ (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display #\~ port)))
(cons #\a (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (locale-abbr-weekday (Datetime-week-day date))
port)))
(cons #\A (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (locale-long-weekday (Datetime-week-day date))
port)))
(cons #\b (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (locale-abbr-month (assert (Datetime-month date) index?))
port)))
(cons #\B (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (locale-long-month (assert (Datetime-month date) index?))
port)))
(cons #\c (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date (localized-message locale-date-time-format)) port)))
(cons #\d (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-day date)
#\0 2)
port)))
(cons #\D (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~m/~d/~y") port)))
(cons #\e (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-day date)
#\Space 2)
port)))
(cons #\f (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-second date) pad-with 2)
port)
(let ([f (decimal-expansion 0 6)])
(when (> (string-length f) 0)
(display (localized-message locale-number-separator) port)
(display f port)))))
(cons #\h (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~b") port)))
(cons #\H (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-hour date)
pad-with 2)
port)))
(cons #\I (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(let ((hr (Datetime-hour date)))
(if (> hr 12)
(display (padding (- hr 12)
pad-with 2)
port)
(display (padding hr
pad-with 2)
port)))))
(cons #\j (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-year-day date)
pad-with 3)
port)))
(cons #\k (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-hour date)
#\0 2)
port)))
(cons #\l (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(let ((hr (if (> (Datetime-hour date) 12)
(- (Datetime-hour date) 12) (Datetime-hour date))))
(display (padding hr #\Space 2)
port))))
(cons #\ (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-month date)
pad-with 2)
port)))
(cons #\M (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-minute date)
pad-with 2)
port)))
(cons #\n (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(newline port)))
(cons #\N (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding 0 pad-with 9)
port)))
(cons #\p (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (locale-am/pm (Datetime-hour date)) port)))
(cons #\r (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~I:~M:~S ~p") port)))
(cons #\s (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (Instant-second (Datetime->InstantUTC date)) port)))
(cons #\S (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (Datetime-second date)
pad-with 2)
port)))
(cons #\t (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display #\Tab port)))
(cons #\T (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~H:~M:~S") port)))
(cons #\U (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(if (> (days-before-first-week date 0) 0)
(display (padding (+ (date-week-number date 0) 1)
#\0 2) port)
(display (padding (date-week-number date 0)
#\0 2) port))))
(cons #\V (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (date-week-number date 1)
#\0 2) port)))
(cons #\w (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (Datetime-week-day date) port)))
(cons #\x (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date (localized-message locale-short-date-format)) port)))
(cons #\X (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date (localized-message locale-time-format)) port)))
(cons #\W (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(if (> (days-before-first-week date 1) 0)
(display (padding (+ (date-week-number date 1) 1)
#\0 2) port)
(display (padding (date-week-number date 1)
#\0 2) port))))
(cons #\y (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (padding (last-n-digits
(Datetime-year date) 2)
pad-with
2)
port)))
(cons #\Y (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (Datetime-year date) port)))
(cons #\z (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(tz-printer (Datetime-offset date) port)))
(cons #\Z (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(locale-print-time-zone date port)))
(cons #\1 (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~Y-~m-~d") port)))
(cons #\2 (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~k:~M:~S~z") port)))
(cons #\3 (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~k:~M:~S") port)))
(cons #\4 (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
(cons #\5 (lambda: ([date : Datetime] [pad-with : (Option Char)] [port : Output-Port])
(display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
(: get-formatter (Char -> (Option DatetimeFormatter)))
(define (get-formatter char)
(let ((associated (assoc char directives)) )
(if associated (cdr associated) #f)))
Jump to Line
Something went wrong with that request. Please try again.