1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays calendar calendar.format.macros
4 combinators io io.streams.string kernel math math.functions
5 math.order math.parser math.parser.private present sequences
9 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
11 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
13 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
15 : write-00 ( n -- ) pad-00 write ;
17 : write-0000 ( n -- ) pad-0000 write ;
19 : write-00000 ( n -- ) pad-00000 write ;
21 : hh ( time -- ) hour>> write-00 ;
23 : mm ( time -- ) minute>> write-00 ;
25 : ss ( time -- ) second>> >integer write-00 ;
27 : D ( time -- ) day>> number>string write ;
29 : DD ( time -- ) day>> write-00 ;
31 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
33 : MM ( time -- ) month>> write-00 ;
35 : MONTH ( time -- ) month>> month-abbreviation write ;
37 : YYYY ( time -- ) year>> write-0000 ;
39 : YYYYY ( time -- ) year>> write-00000 ;
42 read1 swap member? [ "Parse error" throw ] unless ;
44 : read-00 ( -- n ) 2 read string>number ;
46 : read-000 ( -- n ) 3 read string>number ;
48 : read-0000 ( -- n ) 4 read string>number ;
50 : hhmm>timestamp ( hhmm -- timestamp )
52 0 0 0 read-00 read-00 0 instant <timestamp>
53 ] with-string-reader ;
55 GENERIC: day. ( obj -- )
57 M: integer day. ( n -- )
58 number>string dup length 2 < [ bl ] when write ;
60 M: timestamp day. ( timestamp -- )
63 GENERIC: month. ( obj -- )
65 M: array month. ( pair -- )
67 [ month-name write bl number>string print ]
68 [ 1 zeller-congruence ]
69 [ (days-in-month) day-abbreviations2 " " join print ] 2tri
70 over " " <repetition> "" concat-as write
73 1 + + 7 mod zero? [ nl ] [ bl ] if
74 ] with each-integer nl ;
76 M: timestamp month. ( timestamp -- )
77 [ year>> ] [ month>> ] bi 2array month. ;
79 GENERIC: year. ( obj -- )
81 M: integer year. ( n -- )
82 12 [ 1 + 2array month. nl ] with each-integer ;
84 M: timestamp year. ( timestamp -- )
87 : timestamp>mdtm ( timestamp -- str )
88 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
90 : (timestamp>string) ( timestamp -- )
91 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
93 : timestamp>string ( timestamp -- str )
94 [ (timestamp>string) ] with-string-writer ;
96 : write-hhmm ( duration -- )
99 : write-gmt-offset ( gmt-offset -- )
101 { +eq+ [ drop "GMT" write ] }
102 { +lt+ [ "-" write before write-hhmm ] }
103 { +gt+ [ "+" write write-hhmm ] }
106 : write-gmt-offset-number ( gmt-offset -- )
108 { +eq+ [ drop "+0000" write ] }
109 { +lt+ [ "-" write before write-hhmm ] }
110 { +gt+ [ "+" write write-hhmm ] }
113 : timestamp>rfc822 ( timestamp -- str )
114 ! RFC822 timestamp format
115 ! Example: Tue, 15 Nov 1994 08:12:31 +0200
117 [ (timestamp>string) bl ]
118 [ gmt-offset>> write-gmt-offset ]
120 ] with-string-writer ;
122 : timestamp>git-time ( timestamp -- str )
124 [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
125 [ gmt-offset>> write-gmt-offset-number ] bi
126 ] with-string-writer ;
128 : timestamp>http-string ( timestamp -- str )
129 ! http timestamp format
130 ! Example: Tue, 15 Nov 1994 08:12:31 GMT
131 >gmt timestamp>rfc822 ;
133 : (timestamp>cookie-string) ( timestamp -- )
135 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
137 : timestamp>cookie-string ( timestamp -- str )
138 [ (timestamp>cookie-string) ] with-string-writer ;
140 : (write-rfc3339-gmt-offset) ( duration -- )
141 [ hh ":" write ] [ mm ] bi ;
143 : write-rfc3339-gmt-offset ( duration -- )
145 { +eq+ [ drop "Z" write ] }
146 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
147 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
150 ! Should be enough for anyone, allows to not do a fancy
151 ! algorithm to detect infinite decimals (e.g 1/3)
152 : ss.SSSSSS ( timestamp -- )
153 second>> >float "0" 9 6 "f" "C" format-float write ;
155 : (timestamp>rfc3339) ( timestamp -- )
157 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
158 [ gmt-offset>> write-rfc3339-gmt-offset ]
161 : timestamp>rfc3339 ( timestamp -- str )
162 [ (timestamp>rfc3339) ] with-string-writer ;
164 : signed-gmt-offset ( dt ch -- dt' )
165 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
167 : read-rfc3339-gmt-offset ( ch -- dt )
170 { CHAR: Z [ instant ] }
174 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
176 ] dip signed-gmt-offset
180 : read-ymd ( -- y m d )
181 read-0000 "-" expect read-00 "-" expect read-00 ;
183 : read-hms ( -- h m s )
184 read-00 ":" expect read-00 ":" expect read-00 ;
186 : read-rfc3339-seconds ( s -- s' ch )
188 [ string>number ] [ length 10^ ] bi / +
191 : (rfc3339>timestamp) ( -- timestamp )
195 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
196 read-rfc3339-gmt-offset
199 : rfc3339>timestamp ( str -- timestamp )
200 [ (rfc3339>timestamp) ] with-string-reader ;
202 ERROR: invalid-timestamp-format ;
204 : check-timestamp ( obj/f -- obj )
205 [ invalid-timestamp-format ] unless* ;
207 : read-token ( seps -- token )
208 [ read-until ] keep member? check-timestamp drop ;
210 : read-sp ( -- token ) " " read-token ;
212 : checked-number ( str -- n )
213 string>number check-timestamp ;
215 : parse-rfc822-gmt-offset ( string -- dt )
216 dup "GMT" = [ drop instant ] [
218 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
219 ] dip signed-gmt-offset
222 : (rfc822>timestamp) ( -- timestamp )
224 "," read-token day-abbreviations3 member? check-timestamp drop
225 read1 CHAR: \s assert=
226 read-sp checked-number >>day
227 read-sp month-abbreviations index 1 + check-timestamp >>month
228 read-sp checked-number >>year
229 ":" read-token checked-number >>hour
230 ":" read-token checked-number >>minute
231 read-sp checked-number >>second
232 readln parse-rfc822-gmt-offset >>gmt-offset ;
234 : rfc822>timestamp ( str -- timestamp )
235 [ (rfc822>timestamp) ] with-string-reader ;
237 : check-day-name ( str -- )
238 [ day-abbreviations3 member? ] [ day-names member? ] bi or
239 check-timestamp drop ;
241 : (cookie-string>timestamp-1) ( -- timestamp )
243 "," read-token check-day-name
244 read1 CHAR: \s assert=
245 "-" read-token checked-number >>day
246 "-" read-token month-abbreviations index 1 + check-timestamp >>month
247 read-sp checked-number >>year
248 ":" read-token checked-number >>hour
249 ":" read-token checked-number >>minute
250 read-sp checked-number >>second
251 readln parse-rfc822-gmt-offset >>gmt-offset ;
253 : cookie-string>timestamp-1 ( str -- timestamp )
254 [ (cookie-string>timestamp-1) ] with-string-reader ;
256 : (cookie-string>timestamp-2) ( -- timestamp )
258 read-sp check-day-name
259 read-sp month-abbreviations index 1 + check-timestamp >>month
260 read-sp checked-number >>day
261 ":" read-token checked-number >>hour
262 ":" read-token checked-number >>minute
263 read-sp checked-number >>second
264 read-sp checked-number >>year
265 readln parse-rfc822-gmt-offset >>gmt-offset ;
267 : cookie-string>timestamp-2 ( str -- timestamp )
268 [ (cookie-string>timestamp-2) ] with-string-reader ;
270 : cookie-string>timestamp ( str -- timestamp )
272 [ cookie-string>timestamp-1 ]
273 [ cookie-string>timestamp-2 ]
275 } attempt-all-quots ;
277 : (ymdhms>timestamp) ( -- timestamp )
278 read-ymd " " expect read-hms instant <timestamp> ;
280 : ymdhms>timestamp ( str -- timestamp )
281 [ (ymdhms>timestamp) ] with-string-reader ;
283 : (hms>timestamp) ( -- timestamp )
284 0 0 0 read-hms instant <timestamp> ;
286 : hms>timestamp ( str -- timestamp )
287 [ (hms>timestamp) ] with-string-reader ;
289 : (ymd>timestamp) ( -- timestamp )
290 read-ymd <date-gmt> ;
292 : ymd>timestamp ( str -- timestamp )
293 [ (ymd>timestamp) ] with-string-reader ;
295 : (timestamp>ymd) ( timestamp -- )
296 { YYYY "-" MM "-" DD } formatted ;
298 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
299 [ (timestamp>ymd) ] with-string-writer ;
301 : (timestamp>hms) ( timestamp -- )
302 { hh ":" mm ":" ss } formatted ;
304 TYPED: timestamp>hms ( timestamp: timestamp -- str )
305 [ (timestamp>hms) ] with-string-writer ;
307 : (timestamp>hm) ( timestamp -- )
308 { hh ":" mm } formatted ;
310 TYPED: timestamp>hm ( timestamp: timestamp -- str )
311 [ (timestamp>hm) ] with-string-writer ;
313 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
316 { (timestamp>ymd) " " (timestamp>hms) } formatted
317 ] with-string-writer ;
319 : file-time-string ( timestamp -- string )
324 dup now [ year>> ] same?
325 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
328 ] with-string-writer ;
330 M: timestamp present timestamp>string ;
332 TYPED: duration>hm ( duration: duration -- string )
333 [ duration>hours >integer 24 mod pad-00 ]
334 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
336 TYPED: duration>human-readable ( duration: duration -- string )
339 duration>years >integer
341 [ number>string write ]
342 [ 1 > " years, " " year, " ? write ] bi
345 duration>days >integer 365 mod
347 [ number>string write ]
348 [ 1 > " days, " " day, " ? write ] bi
350 ] [ duration>hm write ] tri
351 ] with-string-writer ;