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-gmt-offset) ( duration -- )
99 : write-gmt-offset ( gmt-offset -- )
101 { +eq+ [ drop "GMT" write ] }
102 { +lt+ [ "-" write before (write-gmt-offset) ] }
103 { +gt+ [ "+" write (write-gmt-offset) ] }
106 : timestamp>rfc822 ( timestamp -- str )
107 #! RFC822 timestamp format
108 #! Example: Tue, 15 Nov 1994 08:12:31 +0200
110 [ (timestamp>string) bl ]
111 [ gmt-offset>> write-gmt-offset ]
113 ] with-string-writer ;
115 : timestamp>http-string ( timestamp -- str )
116 #! http timestamp format
117 #! Example: Tue, 15 Nov 1994 08:12:31 GMT
118 >gmt timestamp>rfc822 ;
120 : (timestamp>cookie-string) ( timestamp -- )
122 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
124 : timestamp>cookie-string ( timestamp -- str )
125 [ (timestamp>cookie-string) ] with-string-writer ;
127 : (write-rfc3339-gmt-offset) ( duration -- )
128 [ hh ":" write ] [ mm ] bi ;
130 : write-rfc3339-gmt-offset ( duration -- )
132 { +eq+ [ drop "Z" write ] }
133 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
134 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
137 ! Should be enough for anyone, allows to not do a fancy
138 ! algorithm to detect infinite decimals (e.g 1/3)
139 : ss.SSSSSS ( timestamp -- )
140 second>> >float "%09.6f" format-float write ;
142 : (timestamp>rfc3339) ( timestamp -- )
144 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
145 [ gmt-offset>> write-rfc3339-gmt-offset ]
148 : timestamp>rfc3339 ( timestamp -- str )
149 [ (timestamp>rfc3339) ] with-string-writer ;
151 : signed-gmt-offset ( dt ch -- dt' )
152 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
154 : read-rfc3339-gmt-offset ( ch -- dt )
157 { CHAR: Z [ instant ] }
161 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
163 ] dip signed-gmt-offset
167 : read-ymd ( -- y m d )
168 read-0000 "-" expect read-00 "-" expect read-00 ;
170 : read-hms ( -- h m s )
171 read-00 ":" expect read-00 ":" expect read-00 ;
173 : read-rfc3339-seconds ( s -- s' ch )
175 [ string>number ] [ length 10^ ] bi / +
178 : (rfc3339>timestamp) ( -- timestamp )
182 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
183 read-rfc3339-gmt-offset
186 : rfc3339>timestamp ( str -- timestamp )
187 [ (rfc3339>timestamp) ] with-string-reader ;
189 ERROR: invalid-timestamp-format ;
191 : check-timestamp ( obj/f -- obj )
192 [ invalid-timestamp-format ] unless* ;
194 : read-token ( seps -- token )
195 [ read-until ] keep member? check-timestamp drop ;
197 : read-sp ( -- token ) " " read-token ;
199 : checked-number ( str -- n )
200 string>number check-timestamp ;
202 : parse-rfc822-gmt-offset ( string -- dt )
203 dup "GMT" = [ drop instant ] [
205 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
206 ] dip signed-gmt-offset
209 : (rfc822>timestamp) ( -- timestamp )
211 "," read-token day-abbreviations3 member? check-timestamp drop
212 read1 CHAR: \s assert=
213 read-sp checked-number >>day
214 read-sp month-abbreviations index 1 + check-timestamp >>month
215 read-sp checked-number >>year
216 ":" read-token checked-number >>hour
217 ":" read-token checked-number >>minute
218 read-sp checked-number >>second
219 readln parse-rfc822-gmt-offset >>gmt-offset ;
221 : rfc822>timestamp ( str -- timestamp )
222 [ (rfc822>timestamp) ] with-string-reader ;
224 : check-day-name ( str -- )
225 [ day-abbreviations3 member? ] [ day-names member? ] bi or
226 check-timestamp drop ;
228 : (cookie-string>timestamp-1) ( -- timestamp )
230 "," read-token check-day-name
231 read1 CHAR: \s assert=
232 "-" read-token checked-number >>day
233 "-" read-token month-abbreviations index 1 + check-timestamp >>month
234 read-sp checked-number >>year
235 ":" read-token checked-number >>hour
236 ":" read-token checked-number >>minute
237 read-sp checked-number >>second
238 readln parse-rfc822-gmt-offset >>gmt-offset ;
240 : cookie-string>timestamp-1 ( str -- timestamp )
241 [ (cookie-string>timestamp-1) ] with-string-reader ;
243 : (cookie-string>timestamp-2) ( -- timestamp )
245 read-sp check-day-name
246 read-sp month-abbreviations index 1 + check-timestamp >>month
247 read-sp checked-number >>day
248 ":" read-token checked-number >>hour
249 ":" read-token checked-number >>minute
250 read-sp checked-number >>second
251 read-sp checked-number >>year
252 readln parse-rfc822-gmt-offset >>gmt-offset ;
254 : cookie-string>timestamp-2 ( str -- timestamp )
255 [ (cookie-string>timestamp-2) ] with-string-reader ;
257 : cookie-string>timestamp ( str -- timestamp )
259 [ cookie-string>timestamp-1 ]
260 [ cookie-string>timestamp-2 ]
262 } attempt-all-quots ;
264 : (ymdhms>timestamp) ( -- timestamp )
265 read-ymd " " expect read-hms instant <timestamp> ;
267 : ymdhms>timestamp ( str -- timestamp )
268 [ (ymdhms>timestamp) ] with-string-reader ;
270 : (hms>timestamp) ( -- timestamp )
271 0 0 0 read-hms instant <timestamp> ;
273 : hms>timestamp ( str -- timestamp )
274 [ (hms>timestamp) ] with-string-reader ;
276 : (ymd>timestamp) ( -- timestamp )
277 read-ymd <date-gmt> ;
279 : ymd>timestamp ( str -- timestamp )
280 [ (ymd>timestamp) ] with-string-reader ;
282 : (timestamp>ymd) ( timestamp -- )
283 { YYYY "-" MM "-" DD } formatted ;
285 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
286 [ (timestamp>ymd) ] with-string-writer ;
288 : (timestamp>hms) ( timestamp -- )
289 { hh ":" mm ":" ss } formatted ;
291 TYPED: timestamp>hms ( timestamp: timestamp -- str )
292 [ (timestamp>hms) ] with-string-writer ;
294 : (timestamp>hm) ( timestamp -- )
295 { hh ":" mm } formatted ;
297 TYPED: timestamp>hm ( timestamp: timestamp -- str )
298 [ (timestamp>hm) ] with-string-writer ;
300 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
303 { (timestamp>ymd) " " (timestamp>hms) } formatted
304 ] with-string-writer ;
306 : file-time-string ( timestamp -- string )
311 dup now [ year>> ] same?
312 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
315 ] with-string-writer ;
317 M: timestamp present timestamp>string ;
319 TYPED: duration>hm ( duration: duration -- string )
320 [ duration>hours >integer 24 mod pad-00 ]
321 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
323 TYPED: duration>human-readable ( duration: duration -- string )
326 duration>years >integer
328 [ number>string write ]
329 [ 1 > " years, " " year, " ? write ] bi
332 duration>days >integer 365 mod
334 [ number>string write ]
335 [ 1 > " days, " " day, " ? write ] bi
337 ] [ duration>hm write ] tri
338 ] with-string-writer ;