1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors arrays calendar calendar.format.macros
\r
4 combinators io io.streams.string kernel math math.functions
\r
5 math.order math.parser present sequences typed ;
\r
8 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
\r
10 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
\r
12 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
\r
14 : write-00 ( n -- ) pad-00 write ;
\r
16 : write-0000 ( n -- ) pad-0000 write ;
\r
18 : write-00000 ( n -- ) pad-00000 write ;
\r
20 : hh ( time -- ) hour>> write-00 ;
\r
22 : mm ( time -- ) minute>> write-00 ;
\r
24 : ss ( time -- ) second>> >integer write-00 ;
\r
26 : D ( time -- ) day>> number>string write ;
\r
28 : DD ( time -- ) day>> write-00 ;
\r
30 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
\r
32 : MM ( time -- ) month>> write-00 ;
\r
34 : MONTH ( time -- ) month>> month-abbreviation write ;
\r
36 : YYYY ( time -- ) year>> write-0000 ;
\r
38 : YYYYY ( time -- ) year>> write-00000 ;
\r
41 read1 swap member? [ "Parse error" throw ] unless ;
\r
43 : read-00 ( -- n ) 2 read string>number ;
\r
45 : read-000 ( -- n ) 3 read string>number ;
\r
47 : read-0000 ( -- n ) 4 read string>number ;
\r
49 : hhmm>timestamp ( hhmm -- timestamp )
\r
51 0 0 0 read-00 read-00 0 instant <timestamp>
\r
52 ] with-string-reader ;
\r
54 GENERIC: day. ( obj -- )
\r
56 M: integer day. ( n -- )
\r
57 number>string dup length 2 < [ bl ] when write ;
\r
59 M: timestamp day. ( timestamp -- )
\r
62 GENERIC: month. ( obj -- )
\r
64 M: array month. ( pair -- )
\r
66 [ month-name write bl number>string print ]
\r
67 [ 1 zeller-congruence ]
\r
68 [ (days-in-month) day-abbreviations2 " " join print ] 2tri
\r
69 over " " <repetition> "" concat-as write
\r
72 1 + + 7 mod zero? [ nl ] [ bl ] if
\r
73 ] with each-integer nl ;
\r
75 M: timestamp month. ( timestamp -- )
\r
76 [ year>> ] [ month>> ] bi 2array month. ;
\r
78 GENERIC: year. ( obj -- )
\r
80 M: integer year. ( n -- )
\r
81 12 [ 1 + 2array month. nl ] with each-integer ;
\r
83 M: timestamp year. ( timestamp -- )
\r
86 : timestamp>mdtm ( timestamp -- str )
\r
87 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
\r
89 : (timestamp>string) ( timestamp -- )
\r
90 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
\r
92 : timestamp>string ( timestamp -- str )
\r
93 [ (timestamp>string) ] with-string-writer ;
\r
95 : (write-gmt-offset) ( duration -- )
\r
98 : write-gmt-offset ( gmt-offset -- )
\r
100 { +eq+ [ drop "GMT" write ] }
\r
101 { +lt+ [ "-" write before (write-gmt-offset) ] }
\r
102 { +gt+ [ "+" write (write-gmt-offset) ] }
\r
105 : timestamp>rfc822 ( timestamp -- str )
\r
106 #! RFC822 timestamp format
\r
107 #! Example: Tue, 15 Nov 1994 08:12:31 +0200
\r
109 [ (timestamp>string) bl ]
\r
110 [ gmt-offset>> write-gmt-offset ]
\r
112 ] with-string-writer ;
\r
114 : timestamp>http-string ( timestamp -- str )
\r
115 #! http timestamp format
\r
116 #! Example: Tue, 15 Nov 1994 08:12:31 GMT
\r
117 >gmt timestamp>rfc822 ;
\r
119 : (timestamp>cookie-string) ( timestamp -- )
\r
121 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
\r
123 : timestamp>cookie-string ( timestamp -- str )
\r
124 [ (timestamp>cookie-string) ] with-string-writer ;
\r
126 : (write-rfc3339-gmt-offset) ( duration -- )
\r
127 [ hh ":" write ] [ mm ] bi ;
\r
129 : write-rfc3339-gmt-offset ( duration -- )
\r
131 { +eq+ [ drop "Z" write ] }
\r
132 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
\r
133 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
\r
136 : (timestamp>rfc3339) ( timestamp -- )
\r
138 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
\r
139 [ gmt-offset>> write-rfc3339-gmt-offset ]
\r
142 : timestamp>rfc3339 ( timestamp -- str )
\r
143 [ (timestamp>rfc3339) ] with-string-writer ;
\r
145 : signed-gmt-offset ( dt ch -- dt' )
\r
146 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
\r
148 : read-rfc3339-gmt-offset ( ch -- dt )
\r
149 dup CHAR: Z = [ drop instant ] [
\r
152 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
\r
154 ] dip signed-gmt-offset
\r
157 : read-ymd ( -- y m d )
\r
158 read-0000 "-" expect read-00 "-" expect read-00 ;
\r
160 : read-hms ( -- h m s )
\r
161 read-00 ":" expect read-00 ":" expect read-00 ;
\r
163 : read-rfc3339-seconds ( s -- s' ch )
\r
165 [ string>number ] [ length 10^ ] bi / +
\r
168 : (rfc3339>timestamp) ( -- timestamp )
\r
172 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
\r
173 read-rfc3339-gmt-offset
\r
176 : rfc3339>timestamp ( str -- timestamp )
\r
177 [ (rfc3339>timestamp) ] with-string-reader ;
\r
179 ERROR: invalid-timestamp-format ;
\r
181 : check-timestamp ( obj/f -- obj )
\r
182 [ invalid-timestamp-format ] unless* ;
\r
184 : read-token ( seps -- token )
\r
185 [ read-until ] keep member? check-timestamp drop ;
\r
187 : read-sp ( -- token ) " " read-token ;
\r
189 : checked-number ( str -- n )
\r
190 string>number check-timestamp ;
\r
192 : parse-rfc822-gmt-offset ( string -- dt )
\r
193 dup "GMT" = [ drop instant ] [
\r
195 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
\r
196 ] dip signed-gmt-offset
\r
199 : (rfc822>timestamp) ( -- timestamp )
\r
201 "," read-token day-abbreviations3 member? check-timestamp drop
\r
202 read1 CHAR: \s assert=
\r
203 read-sp checked-number >>day
\r
204 read-sp month-abbreviations index 1 + check-timestamp >>month
\r
205 read-sp checked-number >>year
\r
206 ":" read-token checked-number >>hour
\r
207 ":" read-token checked-number >>minute
\r
208 read-sp checked-number >>second
\r
209 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
211 : rfc822>timestamp ( str -- timestamp )
\r
212 [ (rfc822>timestamp) ] with-string-reader ;
\r
214 : check-day-name ( str -- )
\r
215 [ day-abbreviations3 member? ] [ day-names member? ] bi or
\r
216 check-timestamp drop ;
\r
218 : (cookie-string>timestamp-1) ( -- timestamp )
\r
220 "," read-token check-day-name
\r
221 read1 CHAR: \s assert=
\r
222 "-" read-token checked-number >>day
\r
223 "-" read-token month-abbreviations index 1 + check-timestamp >>month
\r
224 read-sp checked-number >>year
\r
225 ":" read-token checked-number >>hour
\r
226 ":" read-token checked-number >>minute
\r
227 read-sp checked-number >>second
\r
228 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
230 : cookie-string>timestamp-1 ( str -- timestamp )
\r
231 [ (cookie-string>timestamp-1) ] with-string-reader ;
\r
233 : (cookie-string>timestamp-2) ( -- timestamp )
\r
235 read-sp check-day-name
\r
236 read-sp month-abbreviations index 1 + check-timestamp >>month
\r
237 read-sp checked-number >>day
\r
238 ":" read-token checked-number >>hour
\r
239 ":" read-token checked-number >>minute
\r
240 read-sp checked-number >>second
\r
241 read-sp checked-number >>year
\r
242 readln parse-rfc822-gmt-offset >>gmt-offset ;
\r
244 : cookie-string>timestamp-2 ( str -- timestamp )
\r
245 [ (cookie-string>timestamp-2) ] with-string-reader ;
\r
247 : cookie-string>timestamp ( str -- timestamp )
\r
249 [ cookie-string>timestamp-1 ]
\r
250 [ cookie-string>timestamp-2 ]
\r
251 [ rfc822>timestamp ]
\r
252 } attempt-all-quots ;
\r
254 : (ymdhms>timestamp) ( -- timestamp )
\r
255 read-ymd " " expect read-hms instant <timestamp> ;
\r
257 : ymdhms>timestamp ( str -- timestamp )
\r
258 [ (ymdhms>timestamp) ] with-string-reader ;
\r
260 : (hms>timestamp) ( -- timestamp )
\r
261 0 0 0 read-hms instant <timestamp> ;
\r
263 : hms>timestamp ( str -- timestamp )
\r
264 [ (hms>timestamp) ] with-string-reader ;
\r
266 : (ymd>timestamp) ( -- timestamp )
\r
267 read-ymd <date-gmt> ;
\r
269 : ymd>timestamp ( str -- timestamp )
\r
270 [ (ymd>timestamp) ] with-string-reader ;
\r
272 : (timestamp>ymd) ( timestamp -- )
\r
273 { YYYY "-" MM "-" DD } formatted ;
\r
275 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
\r
276 [ (timestamp>ymd) ] with-string-writer ;
\r
278 : (timestamp>hms) ( timestamp -- )
\r
279 { hh ":" mm ":" ss } formatted ;
\r
281 TYPED: timestamp>hms ( timestamp: timestamp -- str )
\r
282 [ (timestamp>hms) ] with-string-writer ;
\r
284 : (timestamp>hm) ( timestamp -- )
\r
285 { hh ":" mm } formatted ;
\r
287 TYPED: timestamp>hm ( timestamp: timestamp -- str )
\r
288 [ (timestamp>hm) ] with-string-writer ;
\r
290 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
\r
293 { (timestamp>ymd) " " (timestamp>hms) } formatted
\r
294 ] with-string-writer ;
\r
296 : file-time-string ( timestamp -- string )
\r
301 dup now [ year>> ] same?
\r
302 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
\r
305 ] with-string-writer ;
\r
307 M: timestamp present timestamp>string ;
\r
309 TYPED: duration>hm ( duration: duration -- string )
\r
310 [ duration>hours >integer 24 mod pad-00 ]
\r
311 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
\r
313 TYPED: duration>human-readable ( duration: duration -- string )
\r
316 duration>years >integer
\r
318 [ number>string write ]
\r
319 [ 1 > " years, " " year, " ? write ] bi
\r
322 duration>days >integer 365 mod
\r
324 [ number>string write ]
\r
325 [ 1 > " days, " " day, " ? write ] bi
\r
327 ] [ duration>hm write ] tri
\r
328 ] with-string-writer ;
\r