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 present sequences typed ;
8 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
10 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
12 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
14 : write-00 ( n -- ) pad-00 write ;
16 : write-0000 ( n -- ) pad-0000 write ;
18 : write-00000 ( n -- ) pad-00000 write ;
20 : hh ( time -- ) hour>> write-00 ;
22 : mm ( time -- ) minute>> write-00 ;
24 : ss ( time -- ) second>> >integer write-00 ;
26 : D ( time -- ) day>> number>string write ;
28 : DD ( time -- ) day>> write-00 ;
30 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
32 : MM ( time -- ) month>> write-00 ;
34 : MONTH ( time -- ) month>> month-abbreviation write ;
36 : YYYY ( time -- ) year>> write-0000 ;
38 : YYYYY ( time -- ) year>> write-00000 ;
41 read1 swap member? [ "Parse error" throw ] unless ;
43 : read-00 ( -- n ) 2 read string>number ;
45 : read-000 ( -- n ) 3 read string>number ;
47 : read-0000 ( -- n ) 4 read string>number ;
49 : hhmm>timestamp ( hhmm -- timestamp )
51 0 0 0 read-00 read-00 0 instant <timestamp>
52 ] with-string-reader ;
54 GENERIC: day. ( obj -- )
56 M: integer day. ( n -- )
57 number>string dup length 2 < [ bl ] when write ;
59 M: timestamp day. ( timestamp -- )
62 GENERIC: month. ( obj -- )
64 M: array month. ( pair -- )
66 [ month-name write bl number>string print ]
67 [ 1 zeller-congruence ]
68 [ (days-in-month) day-abbreviations2 " " join print ] 2tri
69 over " " <repetition> "" concat-as write
72 1 + + 7 mod zero? [ nl ] [ bl ] if
73 ] with each-integer nl ;
75 M: timestamp month. ( timestamp -- )
76 [ year>> ] [ month>> ] bi 2array month. ;
78 GENERIC: year. ( obj -- )
80 M: integer year. ( n -- )
81 12 [ 1 + 2array month. nl ] with each-integer ;
83 M: timestamp year. ( timestamp -- )
86 : timestamp>mdtm ( timestamp -- str )
87 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
89 : (timestamp>string) ( timestamp -- )
90 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
92 : timestamp>string ( timestamp -- str )
93 [ (timestamp>string) ] with-string-writer ;
95 : (write-gmt-offset) ( duration -- )
98 : write-gmt-offset ( gmt-offset -- )
100 { +eq+ [ drop "GMT" write ] }
101 { +lt+ [ "-" write before (write-gmt-offset) ] }
102 { +gt+ [ "+" write (write-gmt-offset) ] }
105 : timestamp>rfc822 ( timestamp -- str )
106 #! RFC822 timestamp format
107 #! Example: Tue, 15 Nov 1994 08:12:31 +0200
109 [ (timestamp>string) bl ]
110 [ gmt-offset>> write-gmt-offset ]
112 ] with-string-writer ;
114 : timestamp>http-string ( timestamp -- str )
115 #! http timestamp format
116 #! Example: Tue, 15 Nov 1994 08:12:31 GMT
117 >gmt timestamp>rfc822 ;
119 : (timestamp>cookie-string) ( timestamp -- )
121 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
123 : timestamp>cookie-string ( timestamp -- str )
124 [ (timestamp>cookie-string) ] with-string-writer ;
126 : (write-rfc3339-gmt-offset) ( duration -- )
127 [ hh ":" write ] [ mm ] bi ;
129 : write-rfc3339-gmt-offset ( duration -- )
131 { +eq+ [ drop "Z" write ] }
132 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
133 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
136 : (timestamp>rfc3339) ( timestamp -- )
138 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
139 [ gmt-offset>> write-rfc3339-gmt-offset ]
142 : timestamp>rfc3339 ( timestamp -- str )
143 [ (timestamp>rfc3339) ] with-string-writer ;
145 : signed-gmt-offset ( dt ch -- dt' )
146 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
148 : read-rfc3339-gmt-offset ( ch -- dt )
151 { CHAR: Z [ instant ] }
155 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
157 ] dip signed-gmt-offset
161 : read-ymd ( -- y m d )
162 read-0000 "-" expect read-00 "-" expect read-00 ;
164 : read-hms ( -- h m s )
165 read-00 ":" expect read-00 ":" expect read-00 ;
167 : read-rfc3339-seconds ( s -- s' ch )
169 [ string>number ] [ length 10^ ] bi / +
172 : (rfc3339>timestamp) ( -- timestamp )
176 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
177 read-rfc3339-gmt-offset
180 : rfc3339>timestamp ( str -- timestamp )
181 [ (rfc3339>timestamp) ] with-string-reader ;
183 ERROR: invalid-timestamp-format ;
185 : check-timestamp ( obj/f -- obj )
186 [ invalid-timestamp-format ] unless* ;
188 : read-token ( seps -- token )
189 [ read-until ] keep member? check-timestamp drop ;
191 : read-sp ( -- token ) " " read-token ;
193 : checked-number ( str -- n )
194 string>number check-timestamp ;
196 : parse-rfc822-gmt-offset ( string -- dt )
197 dup "GMT" = [ drop instant ] [
199 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
200 ] dip signed-gmt-offset
203 : (rfc822>timestamp) ( -- timestamp )
205 "," read-token day-abbreviations3 member? check-timestamp drop
206 read1 CHAR: \s assert=
207 read-sp checked-number >>day
208 read-sp month-abbreviations index 1 + check-timestamp >>month
209 read-sp checked-number >>year
210 ":" read-token checked-number >>hour
211 ":" read-token checked-number >>minute
212 read-sp checked-number >>second
213 readln parse-rfc822-gmt-offset >>gmt-offset ;
215 : rfc822>timestamp ( str -- timestamp )
216 [ (rfc822>timestamp) ] with-string-reader ;
218 : check-day-name ( str -- )
219 [ day-abbreviations3 member? ] [ day-names member? ] bi or
220 check-timestamp drop ;
222 : (cookie-string>timestamp-1) ( -- timestamp )
224 "," read-token check-day-name
225 read1 CHAR: \s assert=
226 "-" read-token checked-number >>day
227 "-" read-token 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 : cookie-string>timestamp-1 ( str -- timestamp )
235 [ (cookie-string>timestamp-1) ] with-string-reader ;
237 : (cookie-string>timestamp-2) ( -- timestamp )
239 read-sp check-day-name
240 read-sp month-abbreviations index 1 + check-timestamp >>month
241 read-sp checked-number >>day
242 ":" read-token checked-number >>hour
243 ":" read-token checked-number >>minute
244 read-sp checked-number >>second
245 read-sp checked-number >>year
246 readln parse-rfc822-gmt-offset >>gmt-offset ;
248 : cookie-string>timestamp-2 ( str -- timestamp )
249 [ (cookie-string>timestamp-2) ] with-string-reader ;
251 : cookie-string>timestamp ( str -- timestamp )
253 [ cookie-string>timestamp-1 ]
254 [ cookie-string>timestamp-2 ]
256 } attempt-all-quots ;
258 : (ymdhms>timestamp) ( -- timestamp )
259 read-ymd " " expect read-hms instant <timestamp> ;
261 : ymdhms>timestamp ( str -- timestamp )
262 [ (ymdhms>timestamp) ] with-string-reader ;
264 : (hms>timestamp) ( -- timestamp )
265 0 0 0 read-hms instant <timestamp> ;
267 : hms>timestamp ( str -- timestamp )
268 [ (hms>timestamp) ] with-string-reader ;
270 : (ymd>timestamp) ( -- timestamp )
271 read-ymd <date-gmt> ;
273 : ymd>timestamp ( str -- timestamp )
274 [ (ymd>timestamp) ] with-string-reader ;
276 : (timestamp>ymd) ( timestamp -- )
277 { YYYY "-" MM "-" DD } formatted ;
279 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
280 [ (timestamp>ymd) ] with-string-writer ;
282 : (timestamp>hms) ( timestamp -- )
283 { hh ":" mm ":" ss } formatted ;
285 TYPED: timestamp>hms ( timestamp: timestamp -- str )
286 [ (timestamp>hms) ] with-string-writer ;
288 : (timestamp>hm) ( timestamp -- )
289 { hh ":" mm } formatted ;
291 TYPED: timestamp>hm ( timestamp: timestamp -- str )
292 [ (timestamp>hm) ] with-string-writer ;
294 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
297 { (timestamp>ymd) " " (timestamp>hms) } formatted
298 ] with-string-writer ;
300 : file-time-string ( timestamp -- string )
305 dup now [ year>> ] same?
306 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
309 ] with-string-writer ;
311 M: timestamp present timestamp>string ;
313 TYPED: duration>hm ( duration: duration -- string )
314 [ duration>hours >integer 24 mod pad-00 ]
315 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
317 TYPED: duration>human-readable ( duration: duration -- string )
320 duration>years >integer
322 [ number>string write ]
323 [ 1 > " years, " " year, " ? write ] bi
326 duration>days >integer 365 mod
328 [ number>string write ]
329 [ 1 > " days, " " day, " ? write ] bi
331 ] [ duration>hm write ] tri
332 ] with-string-writer ;