1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ascii assocs assocs.extras calendar
4 calendar.english combinators combinators.short-circuit
5 combinators.smart countries grouping interval-maps
6 io.encodings.utf8 io.files kernel math math.parser namespaces
7 sequences sequences.extras sorting splitting splitting.extras ;
11 CONSTANT: zoneinfo-paths
13 "vocab:zoneinfo/africa"
14 "vocab:zoneinfo/antarctica"
16 "vocab:zoneinfo/australasia"
17 "vocab:zoneinfo/europe"
18 "vocab:zoneinfo/northamerica"
19 "vocab:zoneinfo/pacificnew"
20 "vocab:zoneinfo/southamerica"
21 "vocab:zoneinfo/backzone"
22 "vocab:zoneinfo/etcetera"
25 CONSTANT: zoneinfo-extra-paths
27 "vocab:zoneinfo/backward"
28 "vocab:zoneinfo/factory"
29 "vocab:zoneinfo/leapseconds"
30 "vocab:zoneinfo/systemv"
33 : zoneinfo-lines ( path -- seq )
35 [ { [ length 0 = ] [ "#" head? ] } 1|| ] reject
36 [ "#" split1-last drop ] map ;
38 TUPLE: zonetab codes lat lng tz comments ;
41 MEMO: zoneinfo-country-zones ( -- seq )
42 "vocab:zoneinfo/zone1970.tab" zoneinfo-lines
46 [ "-+" split* first4 [ append ] 2dip append ] 2dip
50 : parse-zonetabs ( -- seq )
51 zoneinfo-country-zones
52 [ [ codes>> ] [ tz>> ] bi [ 2array ] curry map ] map concat ;
54 : lookup-country-name ( seq -- seq' ) alpha-2 ?at drop ; inline
55 : lookup-country-names ( seq -- seq' ) [ lookup-country-name ] map ;
57 : timezone>country-map ( -- alist )
58 parse-zonetabs [ second ] collect-key-by ;
60 : country>timezones-map ( -- alist )
61 parse-zonetabs [ first ] collect-value-by ;
63 : country-timezones-map ( -- alist )
64 country>timezones-map [ dup lookup-country-names zip ] map-values ;
66 TUPLE: raw-zone name gmt-offset rules/save format until ;
67 TUPLE: raw-rule name from to type in on at-time save letters ;
68 TUPLE: raw-link from to ;
69 TUPLE: raw-leap year month day hms corr r/s ;
72 ! TUPLE: rule name from to at-time ;
74 ! : rule-to ( m string -- m n )
81 : parse-rule ( seq -- rule )
83 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
84 ] input<sequence raw-rule boa ;
86 : parse-link ( seq -- link )
88 { [ drop ] [ ] [ ] } spread
89 ] input<sequence raw-link boa ;
91 : parse-leap ( seq -- link )
93 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
94 ] input<sequence raw-leap boa ;
96 : parse-zone ( seq -- zone )
103 } cleave raw-zone boa ;
105 : parse-rest-of-zone ( prev seq -- zone )
111 } cleave raw-zone boa ;
113 : parse-zoneinfo-line ( prev/f seq -- tuple )
116 { "rule" [ nip parse-rule ] }
117 { "link" [ nip parse-link ] }
118 { "leap" [ nip parse-leap ] }
119 { "zone" [ nip parse-zone ] }
120 [ drop harvest parse-rest-of-zone ]
123 : parse-zoneinfo-file ( path -- seq )
125 [ "\t " split harvest ] map harvest
126 [ parse-zoneinfo-line ] map-with-previous ;
128 MEMO: zoneinfo-files ( -- seq )
129 zoneinfo-paths [ parse-zoneinfo-file ] map ;
131 MEMO: zoneinfo-array ( -- seq )
132 zoneinfo-files concat ;
134 MEMO: zoneinfo-assoc ( -- assoc )
135 zoneinfo-paths [ dup parse-zoneinfo-file ] { } map>assoc ;
137 : raw-rule-map ( -- assoc )
138 zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
140 : current-rule-map ( -- assoc )
142 [ [ to>> "max" = ] filter ] assoc-map
145 : raw-zone-map ( -- assoc )
146 zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
148 : zoneinfo-zones ( -- seq )
150 [ "/" find-subseq? ] partition
151 [ natural-sort ] bi@ append ;
153 GENERIC: zone-matches? ( string rule -- ? )
155 M: raw-rule zone-matches? name>> = ;
156 M: raw-link zone-matches? from>> = ;
157 M: raw-leap zone-matches? 2drop f ;
158 M: raw-zone zone-matches? name>> = ;
160 : find-rules ( country -- rules )
162 [ [ to>> "max" = ] filter ] assoc-map at ;
164 ERROR: zone-not-found name ;
166 : find-zone ( timezone -- zone )
168 [ last ] assoc-map ?at [ zone-not-found ] unless ;
170 : timezone>rules ( timezone -- rules )
173 : find-zone-rules ( timezone -- zone rules )
174 find-zone dup rules/save>> find-rules ;
176 : zone-abbrevs ( -- assoc )
181 letters>> dup { "D" "S" } member? [ drop "" ] unless
183 [ 1 tail surround ] [ nip ] if*
184 ] with V{ } map-as sets:members
187 : number>value ( n -- n' )
195 : on>value ( n -- n' )
196 ! "3", "Thu>=8" always >=, "lastFri"
198 { [ dup 3 swap ?nth CHAR: > = ] [
199 3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
201 { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
205 : zone-month ( timestamp month -- timestamp' )
206 month-abbreviation-index >>month ;
208 ERROR: unknown-day-abbrev day ;
209 : day-abbrev>= ( timestamp day -- timestamp' )
211 { "Sun" [ sunday>= ] }
212 { "Mon" [ monday>= ] }
213 { "Tue" [ tuesday>= ] }
214 { "Wed" [ wednesday>= ] }
215 { "Thu" [ thursday>= ] }
216 { "Fri" [ friday>= ] }
217 { "Sat" [ saturday>= ] }
218 [ unknown-day-abbrev ]
221 : day-abbrev<= ( timestamp day -- timestamp' )
223 { "Sun" [ sunday<= ] }
224 { "Mon" [ monday<= ] }
225 { "Tue" [ tuesday<= ] }
226 { "Wed" [ wednesday<= ] }
227 { "Thu" [ thursday<= ] }
228 { "Fri" [ friday<= ] }
229 { "Sat" [ saturday<= ] }
230 [ unknown-day-abbrev ]
233 : comparison-day-string ( timestamp string -- timestamp )
235 { [ dup ">=" find-subseq? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
236 { [ dup "<=" find-subseq? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
237 [ string>number >>day ]
240 ERROR: unknown-last-day string ;
242 : last-day-string ( timestamp string -- timestamp )
244 { "lastSun" [ last-sunday-of-month ] }
245 { "lastMon" [ last-monday-of-month ] }
246 { "lastTue" [ last-tuesday-of-month ] }
247 { "lastWed" [ last-wednesday-of-month ] }
248 { "lastThu" [ last-thursday-of-month ] }
249 { "lastFri" [ last-friday-of-month ] }
250 { "lastSat" [ last-saturday-of-month ] }
254 ! "lastFri" | "Fri<=1" | "Sat>=2" | "15"
255 : zone-day ( timestamp text -- timestamp' )
259 comparison-day-string
262 : string>year ( str -- year )
263 string>number <year-gmt> ;
265 : rule-year>years ( raw-rule -- from to )
266 [ from>> ] [ to>> ] bi
268 { [ over "min" = ] [ [ drop -1/0. ] [ string>year ] bi* ] }
269 { [ dup "max" = ] [ [ string>year ] [ drop 1/0. ] bi* ] }
270 { [ dup "only" = ] [ drop dup [ string>year ] bi@ ] }
271 [ [ string>year ] bi@ ]
274 : parse-hms ( str -- hms-seq )
275 ":" split [ string>number ] map 3 0 pad-tail ;
277 : parse-offset ( str -- hms-seq )
278 "-" ?head [ parse-hms ] dip [ [ neg ] map ] when ;
280 ! XXX: Don't just drop the s/u, e.g. 2:00:00s
281 : zone-time ( timestamp time -- timestamp' )
282 [ Letter? ] split-tail drop
283 parse-offset first3 set-time ;
285 : hm>duration ( str -- duration )
286 ":" split1 "0" or [ string>number ] bi@
287 [ instant ] 2dip 0 set-time ;
289 : hms>duration ( str -- duration )
290 ":" split 3 "0" pad-tail
291 [ string>number ] map first3
292 [ instant ] 3dip set-time ;
294 : rule>timestamp-rest ( timestamp zone -- from )
296 [ over fp-infinity? [ drop ] [ in>> month-abbreviation-index >>month ] if ]
297 [ over fp-infinity? [ drop ] [ on>> zone-day ] if ]
298 [ over fp-infinity? [ drop ] [ at-time>> zone-time ] if ]
301 : rule>timestamps ( zone -- from to )
302 [ rule-year>years ] keep
303 [ nip rule>timestamp-rest ]
304 [ nipd rule>timestamp-rest ] 3bi ;
306 : until>timestamp ( seq -- unix-time )
308 4 f pad-tail first4 {
309 [ string>number <year-gmt> ]
310 [ [ zone-month ] when* ]
311 [ [ zone-day ] when* ]
312 [ [ zone-time ] when* ]
313 } spread timestamp>unix-time
316 : raw-zones>interval-map ( raw-zones -- interval-map )
318 [ until>> until>timestamp ] map
319 -1/0. prefix 2 <clumps> [ >array ] map
321 [ first2 1 - 2array ] map-keys <interval-map> ;
323 : timezone>interval-map ( timezone-name -- interval-map )
324 raw-zone-map at raw-zones>interval-map ;
326 : gmt-offset ( timestamp timezone-name -- gmt-offset )
327 [ timestamp>unix-time ]
328 [ raw-zones>interval-map ] bi* interval-at ;
330 : name>rules ( name -- rules )
333 [ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
334 [ [ save>> hms>duration ] [ letters>> ] bi 2array ] bi 2array
338 : chicago-zones ( -- interval-map ) "America/Chicago" timezone>interval-map ;
339 : us-rules ( -- rules ) "US" name>rules ;
340 : us-timezones ( -- timezones )
341 country>timezones-map "US" of ;
343 : puerto-rico-timezone-countries ( -- countries )
344 timezone>country-map "America/Puerto_Rico" of lookup-country-names ;