| blob | a7c4410aa560516d1239b5fde1eccda750b9d14b |
1 ! Copyright (C) 2008 Slava Pestov.\r
2 ! See http://factorcode.org/license.txt for BSD license.\r
3 USING: math math.order math.parser math.functions kernel\r
4 sequences io accessors arrays io.streams.string splitting\r
5 combinators accessors calendar calendar.format.macros present ;\r
6 IN: calendar.format\r
7 \r
8 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
9 \r
10 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
11 \r
12 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
13 \r
14 : write-00 ( n -- ) pad-00 write ;\r
15 \r
16 : write-0000 ( n -- ) pad-0000 write ;\r
17 \r
18 : write-00000 ( n -- ) pad-00000 write ;\r
19 \r
20 : hh ( time -- ) hour>> write-00 ;\r
21 \r
22 : mm ( time -- ) minute>> write-00 ;\r
23 \r
24 : ss ( time -- ) second>> >integer write-00 ;\r
25 \r
26 : D ( time -- ) day>> number>string write ;\r
27 \r
28 : DD ( time -- ) day>> write-00 ;\r
29 \r
30 : DAY ( time -- ) day-of-week day-abbreviation3 write ;\r
31 \r
32 : MM ( time -- ) month>> write-00 ;\r
33 \r
34 : MONTH ( time -- ) month>> month-abbreviation write ;\r
35 \r
36 : YYYY ( time -- ) year>> write-0000 ;\r
37 \r
38 : YYYYY ( time -- ) year>> write-00000 ;\r
39 \r
40 : expect ( str -- )\r
41 read1 swap member? [ "Parse error" throw ] unless ;\r
42 \r
43 : read-00 ( -- n ) 2 read string>number ;\r
44 \r
45 : read-000 ( -- n ) 3 read string>number ;\r
46 \r
47 : read-0000 ( -- n ) 4 read string>number ;\r
48 \r
49 GENERIC: day. ( obj -- )\r
50 \r
51 M: integer day. ( n -- )\r
52 number>string dup length 2 < [ bl ] when write ;\r
53 \r
54 M: timestamp day. ( timestamp -- )\r
55 day>> day. ;\r
56 \r
57 GENERIC: month. ( obj -- )\r
58 \r
59 M: array month. ( pair -- )\r
60 first2\r
61 [ month-name write bl number>string print ]\r
62 [ 1 zeller-congruence ]\r
63 [ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
64 over " " <repetition> concat write\r
65 [\r
66 [ 1+ day. ] keep\r
67 1+ + 7 mod zero? [ nl ] [ bl ] if\r
68 ] with each nl ;\r
69 \r
70 M: timestamp month. ( timestamp -- )\r
71 [ year>> ] [ month>> ] bi 2array month. ;\r
72 \r
73 GENERIC: year. ( obj -- )\r
74 \r
75 M: integer year. ( n -- )\r
76 12 [ 1+ 2array month. nl ] with each ;\r
77 \r
78 M: timestamp year. ( timestamp -- )\r
79 year>> year. ;\r
80 \r
81 : (timestamp>string) ( timestamp -- )\r
82 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;\r
83 \r
84 : timestamp>string ( timestamp -- str )\r
85 [ (timestamp>string) ] with-string-writer ;\r
86 \r
87 : (write-gmt-offset) ( duration -- )\r
88 [ hh ] [ mm ] bi ;\r
89 \r
90 : write-gmt-offset ( gmt-offset -- )\r
91 dup instant <=> {\r
92 { +eq+ [ drop "GMT" write ] }\r
93 { +lt+ [ "-" write before (write-gmt-offset) ] }\r
94 { +gt+ [ "+" write (write-gmt-offset) ] }\r
95 } case ;\r
96 \r
97 : timestamp>rfc822 ( timestamp -- str )\r
98 #! RFC822 timestamp format\r
99 #! Example: Tue, 15 Nov 1994 08:12:31 +0200\r
100 [\r
101 [ (timestamp>string) " " write ]\r
102 [ gmt-offset>> write-gmt-offset ]\r
103 bi\r
104 ] with-string-writer ;\r
105 \r
106 : timestamp>http-string ( timestamp -- str )\r
107 #! http timestamp format\r
108 #! Example: Tue, 15 Nov 1994 08:12:31 GMT\r
109 >gmt timestamp>rfc822 ;\r
110 \r
111 : (timestamp>cookie-string) ( timestamp -- )\r
112 >gmt\r
113 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;\r
114 \r
115 : timestamp>cookie-string ( timestamp -- str )\r
116 [ (timestamp>cookie-string) ] with-string-writer ;\r
117 \r
118 : (write-rfc3339-gmt-offset) ( duration -- )\r
119 [ hh ":" write ] [ mm ] bi ;\r
120 \r
121 : write-rfc3339-gmt-offset ( duration -- )\r
122 dup instant <=> {\r
123 { +eq+ [ drop "Z" write ] }\r
124 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }\r
125 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }\r
126 } case ;\r
127 \r
128 : (timestamp>rfc3339) ( timestamp -- )\r
129 {\r
130 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss\r
131 [ gmt-offset>> write-rfc3339-gmt-offset ]\r
132 } formatted ;\r
133 \r
134 : timestamp>rfc3339 ( timestamp -- str )\r
135 [ (timestamp>rfc3339) ] with-string-writer ;\r
136 \r
137 : signed-gmt-offset ( dt ch -- dt' )\r
138 { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;\r
139 \r
140 : read-rfc3339-gmt-offset ( ch -- dt )\r
141 dup CHAR: Z = [ drop instant ] [\r
142 [\r
143 read-00 hours\r
144 read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes\r
145 time+\r
146 ] dip signed-gmt-offset\r
147 ] if ;\r
148 \r
149 : read-ymd ( -- y m d )\r
150 read-0000 "-" expect read-00 "-" expect read-00 ;\r
151 \r
152 : read-hms ( -- h m s )\r
153 read-00 ":" expect read-00 ":" expect read-00 ;\r
154 \r
155 : read-rfc3339-seconds ( s -- s' ch )\r
156 "+-Z" read-until [\r
157 [ string>number ] [ length 10 swap ^ ] bi / +\r
158 ] dip ;\r
159 \r
160 : (rfc3339>timestamp) ( -- timestamp )\r
161 read-ymd\r
162 "Tt" expect\r
163 read-hms\r
164 read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case\r
165 read-rfc3339-gmt-offset\r
166 <timestamp> ;\r
167 \r
168 : rfc3339>timestamp ( str -- timestamp )\r
169 [ (rfc3339>timestamp) ] with-string-reader ;\r
170 \r
171 ERROR: invalid-timestamp-format ;\r
172 \r
173 : check-timestamp ( obj/f -- obj )\r
174 [ invalid-timestamp-format ] unless* ;\r
175 \r
176 : read-token ( seps -- token )\r
177 [ read-until ] keep member? check-timestamp drop ;\r
178 \r
179 : read-sp ( -- token ) " " read-token ;\r
180 \r
181 : checked-number ( str -- n )\r
182 string>number check-timestamp ;\r
183 \r
184 : parse-rfc822-gmt-offset ( string -- dt )\r
185 dup "GMT" = [ drop instant ] [\r
186 unclip [ \r
187 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+\r
188 ] dip signed-gmt-offset\r
189 ] if ;\r
190 \r
191 : (rfc822>timestamp) ( -- timestamp )\r
192 timestamp new\r
193 "," read-token day-abbreviations3 member? check-timestamp drop\r
194 read1 CHAR: \s assert=\r
195 read-sp checked-number >>day\r
196 read-sp month-abbreviations index 1+ check-timestamp >>month\r
197 read-sp checked-number >>year\r
198 ":" read-token checked-number >>hour\r
199 ":" read-token checked-number >>minute\r
200 " " read-token checked-number >>second\r
201 readln parse-rfc822-gmt-offset >>gmt-offset ;\r
202 \r
203 : rfc822>timestamp ( str -- timestamp )\r
204 [ (rfc822>timestamp) ] with-string-reader ;\r
205 \r
206 : check-day-name ( str -- )\r
207 [ day-abbreviations3 member? ] [ day-names member? ] bi or\r
208 check-timestamp drop ;\r
209 \r
210 : (cookie-string>timestamp-1) ( -- timestamp )\r
211 timestamp new\r
212 "," read-token check-day-name\r
213 read1 CHAR: \s assert=\r
214 "-" read-token checked-number >>day\r
215 "-" read-token month-abbreviations index 1+ check-timestamp >>month\r
216 read-sp checked-number >>year\r
217 ":" read-token checked-number >>hour\r
218 ":" read-token checked-number >>minute\r
219 " " read-token checked-number >>second\r
220 readln parse-rfc822-gmt-offset >>gmt-offset ;\r
221 \r
222 : cookie-string>timestamp-1 ( str -- timestamp )\r
223 [ (cookie-string>timestamp-1) ] with-string-reader ;\r
224 \r
225 : (cookie-string>timestamp-2) ( -- timestamp )\r
226 timestamp new\r
227 read-sp check-day-name\r
228 read-sp month-abbreviations index 1+ check-timestamp >>month\r
229 read-sp checked-number >>day\r
230 ":" read-token checked-number >>hour\r
231 ":" read-token checked-number >>minute\r
232 " " read-token checked-number >>second\r
233 read-sp checked-number >>year\r
234 readln parse-rfc822-gmt-offset >>gmt-offset ;\r
235 \r
236 : cookie-string>timestamp-2 ( str -- timestamp )\r
237 [ (cookie-string>timestamp-2) ] with-string-reader ;\r
238 \r
239 : cookie-string>timestamp ( str -- timestamp )\r
240 {\r
241 [ cookie-string>timestamp-1 ]\r
242 [ cookie-string>timestamp-2 ]\r
243 [ rfc822>timestamp ]\r
244 } attempt-all-quots ;\r
245 \r
246 : (ymdhms>timestamp) ( -- timestamp )\r
247 read-ymd " " expect read-hms instant <timestamp> ;\r
248 \r
249 : ymdhms>timestamp ( str -- timestamp )\r
250 [ (ymdhms>timestamp) ] with-string-reader ;\r
251 \r
252 : (hms>timestamp) ( -- timestamp )\r
253 0 0 0 read-hms instant <timestamp> ;\r
254 \r
255 : hms>timestamp ( str -- timestamp )\r
256 [ (hms>timestamp) ] with-string-reader ;\r
257 \r
258 : (ymd>timestamp) ( -- timestamp )\r
259 read-ymd 0 0 0 instant <timestamp> ;\r
260 \r
261 : ymd>timestamp ( str -- timestamp )\r
262 [ (ymd>timestamp) ] with-string-reader ;\r
263 \r
264 : (timestamp>ymd) ( timestamp -- )\r
265 { YYYY "-" MM "-" DD } formatted ;\r
266 \r
267 : timestamp>ymd ( timestamp -- str )\r
268 [ (timestamp>ymd) ] with-string-writer ;\r
269 \r
270 : (timestamp>hms) ( timestamp -- )\r
271 { hh ":" mm ":" ss } formatted ;\r
272 \r
273 : timestamp>hms ( timestamp -- str )\r
274 [ (timestamp>hms) ] with-string-writer ;\r
275 \r
276 : timestamp>ymdhms ( timestamp -- str )\r
277 [\r
278 >gmt\r
279 { (timestamp>ymd) " " (timestamp>hms) } formatted\r
280 ] with-string-writer ;\r
281 \r
282 : file-time-string ( timestamp -- string )\r
283 [\r
284 {\r
285 MONTH " " DD " "\r
286 [\r
287 dup now [ year>> ] bi@ =\r
288 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if\r
289 ]\r
290 } formatted\r
291 ] with-string-writer ;\r
292 \r
293 M: timestamp present timestamp>string ;\r