1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar calendar.english
4 calendar.format.macros combinators io io.streams.string kernel math
5 math.functions math.order math.parser math.parser.private present
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 CONSTANT: rfc822-named-zones H{
226 : parse-rfc822-military-offset ( string -- dt )
228 -1 -2 -3 -4 -5 -6 -7 -8 -9 f -10 -11 -12
229 1 2 3 4 5 6 7 8 9 10 11 12 0
232 : parse-rfc822-gmt-offset ( string -- dt )
234 { [ dup { "UTC" "GMT" } member? ] [ drop instant ] }
235 { [ dup length 1 = ] [ parse-rfc822-military-offset ] }
236 { [ dup rfc822-named-zones key? ] [ rfc822-named-zones at hours ] }
239 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
240 ] dip signed-gmt-offset
244 : (rfc822>timestamp) ( -- timestamp )
246 "," read-token day-abbreviations3 member? check-timestamp drop
247 read1 CHAR: \s assert=
248 read-sp checked-number >>day
249 read-sp month-abbreviations index 1 + check-timestamp >>month
250 read-sp checked-number >>year
251 ":" read-token checked-number >>hour
252 ":" read-token checked-number >>minute
253 read-sp checked-number >>second
254 readln parse-rfc822-gmt-offset >>gmt-offset ;
256 : rfc822>timestamp ( str -- timestamp )
257 [ (rfc822>timestamp) ] with-string-reader ;
259 : check-day-name ( str -- )
260 [ day-abbreviations3 member? ] [ day-names member? ] bi or
261 check-timestamp drop ;
263 : (cookie-string>timestamp-1) ( -- timestamp )
265 "," read-token check-day-name
266 read1 CHAR: \s assert=
267 "-" read-token checked-number >>day
268 "-" read-token month-abbreviations index 1 + check-timestamp >>month
269 read-sp checked-number >>year
270 ":" read-token checked-number >>hour
271 ":" read-token checked-number >>minute
272 read-sp checked-number >>second
273 readln parse-rfc822-gmt-offset >>gmt-offset ;
275 : cookie-string>timestamp-1 ( str -- timestamp )
276 [ (cookie-string>timestamp-1) ] with-string-reader ;
278 : (cookie-string>timestamp-2) ( -- timestamp )
280 read-sp check-day-name
281 read-sp month-abbreviations index 1 + check-timestamp >>month
282 read-sp checked-number >>day
283 ":" read-token checked-number >>hour
284 ":" read-token checked-number >>minute
285 read-sp checked-number >>second
286 read-sp checked-number >>year
287 readln parse-rfc822-gmt-offset >>gmt-offset ;
289 : cookie-string>timestamp-2 ( str -- timestamp )
290 [ (cookie-string>timestamp-2) ] with-string-reader ;
292 : cookie-string>timestamp ( str -- timestamp )
294 [ cookie-string>timestamp-1 ]
295 [ cookie-string>timestamp-2 ]
297 } attempt-all-quots ;
299 : (ymdhms>timestamp) ( -- timestamp )
300 read-ymd " " expect read-hms instant <timestamp> ;
302 : ymdhms>timestamp ( str -- timestamp )
303 [ (ymdhms>timestamp) ] with-string-reader ;
305 : (hms>timestamp) ( -- timestamp )
306 0 0 0 read-hms instant <timestamp> ;
308 : hms>timestamp ( str -- timestamp )
309 [ (hms>timestamp) ] with-string-reader ;
311 : hm>timestamp ( str -- timestamp )
312 ":00" append hms>timestamp ;
314 : (ymd>timestamp) ( -- timestamp )
315 read-ymd <date-gmt> ;
317 : ymd>timestamp ( str -- timestamp )
318 [ (ymd>timestamp) ] with-string-reader ;
320 : (timestamp>ymd) ( timestamp -- )
321 { YYYY "-" MM "-" DD } formatted ;
323 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
324 [ (timestamp>ymd) ] with-string-writer ;
326 : (timestamp>hms) ( timestamp -- )
327 { hh ":" mm ":" ss } formatted ;
329 TYPED: timestamp>hms ( timestamp: timestamp -- str )
330 [ (timestamp>hms) ] with-string-writer ;
332 : (timestamp>hm) ( timestamp -- )
333 { hh ":" mm } formatted ;
335 TYPED: timestamp>hm ( timestamp: timestamp -- str )
336 [ (timestamp>hm) ] with-string-writer ;
338 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
341 { (timestamp>ymd) " " (timestamp>hms) } formatted
342 ] with-string-writer ;
344 : file-time-string ( timestamp -- string )
349 dup now [ year>> ] same?
350 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
353 ] with-string-writer ;
355 M: timestamp present timestamp>string ;
357 TYPED: duration>hm ( duration: duration -- string )
358 [ duration>hours >integer 24 mod pad-00 ]
359 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
361 TYPED: duration>human-readable ( duration: duration -- string )
364 duration>years >integer
366 [ number>string write ]
367 [ 1 > " years, " " year, " ? write ] bi
370 duration>days >integer 365 mod
372 [ number>string write ]
373 [ 1 > " days, " " day, " ? write ] bi
375 ] [ duration>hm write ] tri
376 ] with-string-writer ;