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 formatting io io.streams.string kernel math
5 math.functions 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 ! Should be enough for anyone, allows to not do a fancy
137 ! algorithm to detect infinite decimals (e.g 1/3)
138 : write-rfc3339-seconds ( timestamp -- )
140 "%.6f" sprintf [ CHAR: 0 = ] trim
141 dup length 1 > [ write ] [ drop ] if
144 : (timestamp>rfc3339) ( timestamp -- )
146 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
147 write-rfc3339-seconds
148 [ gmt-offset>> write-rfc3339-gmt-offset ]
151 : timestamp>rfc3339 ( timestamp -- str )
152 [ (timestamp>rfc3339) ] with-string-writer ;
154 : signed-gmt-offset ( dt ch -- dt' )
155 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
157 : read-rfc3339-gmt-offset ( ch -- dt )
160 { CHAR: Z [ instant ] }
164 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
166 ] dip signed-gmt-offset
170 : read-ymd ( -- y m d )
171 read-0000 "-" expect read-00 "-" expect read-00 ;
173 : read-hms ( -- h m s )
174 read-00 ":" expect read-00 ":" expect read-00 ;
176 : read-rfc3339-seconds ( s -- s' ch )
178 [ string>number ] [ length 10^ ] bi / +
181 : (rfc3339>timestamp) ( -- timestamp )
185 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
186 read-rfc3339-gmt-offset
189 : rfc3339>timestamp ( str -- timestamp )
190 [ (rfc3339>timestamp) ] with-string-reader ;
192 ERROR: invalid-timestamp-format ;
194 : check-timestamp ( obj/f -- obj )
195 [ invalid-timestamp-format ] unless* ;
197 : read-token ( seps -- token )
198 [ read-until ] keep member? check-timestamp drop ;
200 : read-sp ( -- token ) " " read-token ;
202 : checked-number ( str -- n )
203 string>number check-timestamp ;
205 : parse-rfc822-gmt-offset ( string -- dt )
206 dup "GMT" = [ drop instant ] [
208 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
209 ] dip signed-gmt-offset
212 : (rfc822>timestamp) ( -- timestamp )
214 "," read-token day-abbreviations3 member? check-timestamp drop
215 read1 CHAR: \s assert=
216 read-sp checked-number >>day
217 read-sp month-abbreviations index 1 + check-timestamp >>month
218 read-sp checked-number >>year
219 ":" read-token checked-number >>hour
220 ":" read-token checked-number >>minute
221 read-sp checked-number >>second
222 readln parse-rfc822-gmt-offset >>gmt-offset ;
224 : rfc822>timestamp ( str -- timestamp )
225 [ (rfc822>timestamp) ] with-string-reader ;
227 : check-day-name ( str -- )
228 [ day-abbreviations3 member? ] [ day-names member? ] bi or
229 check-timestamp drop ;
231 : (cookie-string>timestamp-1) ( -- timestamp )
233 "," read-token check-day-name
234 read1 CHAR: \s assert=
235 "-" read-token checked-number >>day
236 "-" read-token month-abbreviations index 1 + check-timestamp >>month
237 read-sp checked-number >>year
238 ":" read-token checked-number >>hour
239 ":" read-token checked-number >>minute
240 read-sp checked-number >>second
241 readln parse-rfc822-gmt-offset >>gmt-offset ;
243 : cookie-string>timestamp-1 ( str -- timestamp )
244 [ (cookie-string>timestamp-1) ] with-string-reader ;
246 : (cookie-string>timestamp-2) ( -- timestamp )
248 read-sp check-day-name
249 read-sp month-abbreviations index 1 + check-timestamp >>month
250 read-sp checked-number >>day
251 ":" read-token checked-number >>hour
252 ":" read-token checked-number >>minute
253 read-sp checked-number >>second
254 read-sp checked-number >>year
255 readln parse-rfc822-gmt-offset >>gmt-offset ;
257 : cookie-string>timestamp-2 ( str -- timestamp )
258 [ (cookie-string>timestamp-2) ] with-string-reader ;
260 : cookie-string>timestamp ( str -- timestamp )
262 [ cookie-string>timestamp-1 ]
263 [ cookie-string>timestamp-2 ]
265 } attempt-all-quots ;
267 : (ymdhms>timestamp) ( -- timestamp )
268 read-ymd " " expect read-hms instant <timestamp> ;
270 : ymdhms>timestamp ( str -- timestamp )
271 [ (ymdhms>timestamp) ] with-string-reader ;
273 : (hms>timestamp) ( -- timestamp )
274 0 0 0 read-hms instant <timestamp> ;
276 : hms>timestamp ( str -- timestamp )
277 [ (hms>timestamp) ] with-string-reader ;
279 : (ymd>timestamp) ( -- timestamp )
280 read-ymd <date-gmt> ;
282 : ymd>timestamp ( str -- timestamp )
283 [ (ymd>timestamp) ] with-string-reader ;
285 : (timestamp>ymd) ( timestamp -- )
286 { YYYY "-" MM "-" DD } formatted ;
288 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
289 [ (timestamp>ymd) ] with-string-writer ;
291 : (timestamp>hms) ( timestamp -- )
292 { hh ":" mm ":" ss } formatted ;
294 TYPED: timestamp>hms ( timestamp: timestamp -- str )
295 [ (timestamp>hms) ] with-string-writer ;
297 : (timestamp>hm) ( timestamp -- )
298 { hh ":" mm } formatted ;
300 TYPED: timestamp>hm ( timestamp: timestamp -- str )
301 [ (timestamp>hm) ] with-string-writer ;
303 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
306 { (timestamp>ymd) " " (timestamp>hms) } formatted
307 ] with-string-writer ;
309 : file-time-string ( timestamp -- string )
314 dup now [ year>> ] same?
315 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
318 ] with-string-writer ;
320 M: timestamp present timestamp>string ;
322 TYPED: duration>hm ( duration: duration -- string )
323 [ duration>hours >integer 24 mod pad-00 ]
324 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
326 TYPED: duration>human-readable ( duration: duration -- string )
329 duration>years >integer
331 [ number>string write ]
332 [ 1 > " years, " " year, " ? write ] bi
335 duration>days >integer 365 mod
337 [ number>string write ]
338 [ 1 > " days, " " day, " ? write ] bi
340 ] [ duration>hm write ] tri
341 ] with-string-writer ;