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.smart grouping
5 interval-maps io.encodings.utf8 io.files kernel math math.parser
6 memoize namespaces sequences sequences.extras sorting splitting
10 CONSTANT: zoneinfo-paths
12 "vocab:zoneinfo/africa"
13 "vocab:zoneinfo/antarctica"
15 "vocab:zoneinfo/australasia"
16 "vocab:zoneinfo/europe"
17 "vocab:zoneinfo/northamerica"
18 "vocab:zoneinfo/pacificnew"
19 "vocab:zoneinfo/southamerica"
20 "vocab:zoneinfo/etcetera"
21 "vocab:zoneinfo/factory"
22 "vocab:zoneinfo/leapseconds"
23 "vocab:zoneinfo/systemv"
28 TUPLE: raw-zone name gmt-offset rules/save format until ;
29 TUPLE: raw-rule name from to type in on at-time save letters ;
30 TUPLE: raw-link from to ;
31 TUPLE: raw-leap year month day hms corr r/s ;
34 TUPLE: rule name from to at-time ;
36 : rule-to ( m string -- m n )
43 : parse-rule ( seq -- rule )
45 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
46 ] input<sequence raw-rule boa ;
48 : parse-link ( seq -- link )
50 { [ drop ] [ ] [ ] } spread
51 ] input<sequence raw-link boa ;
53 : parse-leap ( seq -- link )
55 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
56 ] input<sequence raw-leap boa ;
58 : parse-zone ( seq -- zone )
65 } cleave raw-zone boa ;
67 : parse-partial-zone ( seq -- zone )
68 [ last-zone get name>> ] dip
74 } cleave raw-zone boa ;
76 : parse-line ( seq -- tuple )
79 { "rule" [ parse-rule ] }
80 { "link" [ parse-link ] }
81 { "leap" [ parse-leap ] }
82 { "zone" [ parse-zone dup last-zone set ] }
83 [ drop harvest parse-partial-zone ]
86 : parse-zoneinfo-file ( path -- seq )
88 [ "#" split1 drop ] map harvest
89 [ "\t " split harvest ] map harvest
90 [ [ parse-line ] map ] with-scope ;
92 MEMO: zoneinfo-files ( -- seq )
93 zoneinfo-paths [ parse-zoneinfo-file ] map ;
95 MEMO: zoneinfo-array ( -- seq )
96 zoneinfo-files concat ;
98 : raw-rule-map ( -- assoc )
99 zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
101 : raw-zone-map ( -- assoc )
102 zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
104 : zoneinfo-zones ( -- seq )
106 [ "/" swap subseq? ] partition
107 [ natural-sort ] bi@ append ;
109 GENERIC: zone-matches? ( string rule -- ? )
111 M: raw-rule zone-matches? name>> = ;
112 M: raw-link zone-matches? from>> = ;
113 M: raw-leap zone-matches? 2drop f ;
114 M: raw-zone zone-matches? name>> = ;
116 : find-rules ( string -- rules )
118 [ [ to>> "max" = ] filter ] assoc-map at ;
120 ERROR: zone-not-found name ;
122 : find-zone ( string -- zone )
124 [ last ] assoc-map ?at [ zone-not-found ] unless ;
126 : find-zone-rules ( string -- zone rules )
127 find-zone dup rules/save>> find-rules ;
129 : zone-abbrevs ( -- assoc )
131 find-zone-rules [ format>> ] dip
133 letters>> swap "%" split1 dup [ 1 tail ] when surround
137 : number>value ( n -- n' )
145 : on>value ( n -- n' )
146 ! "3", "Thu>=8" always >=, "lastFri"
148 { [ dup 3 swap ?nth CHAR: > = ] [
149 3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
151 { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
155 : zone-month ( timestamp month -- timestamp' )
156 month-abbreviation-index >>month ;
158 ERROR: unknown-day-abbrev day ;
159 : day-abbrev>= ( timestamp day -- timestamp' )
161 { "Sun" [ sunday>= ] }
162 { "Mon" [ monday>= ] }
163 { "Tue" [ tuesday>= ] }
164 { "Wed" [ wednesday>= ] }
165 { "Thu" [ thursday>= ] }
166 { "Fri" [ friday>= ] }
167 { "Sat" [ saturday>= ] }
168 [ unknown-day-abbrev ]
171 : day-abbrev<= ( timestamp day -- timestamp' )
173 { "Sun" [ sunday<= ] }
174 { "Mon" [ monday<= ] }
175 { "Tue" [ tuesday<= ] }
176 { "Wed" [ wednesday<= ] }
177 { "Thu" [ thursday<= ] }
178 { "Fri" [ friday<= ] }
179 { "Sat" [ saturday<= ] }
180 [ unknown-day-abbrev ]
183 : comparison-day-string ( timestamp string -- timestamp )
185 { [ ">=" over subseq? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
186 { [ "<=" over subseq? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
187 [ string>number >>day ]
190 ERROR: unknown-last-day string ;
192 : last-day-string ( timestamp string -- timestamp )
194 { "lastSun" [ last-sunday-of-month ] }
195 { "lastMon" [ last-monday-of-month ] }
196 { "lastTue" [ last-tuesday-of-month ] }
197 { "lastWed" [ last-wednesday-of-month ] }
198 { "lastThu" [ last-thursday-of-month ] }
199 { "lastFri" [ last-friday-of-month ] }
200 { "lastSat" [ last-saturday-of-month ] }
204 ! "lastFri" | "Fri<=1" | "Sat>=2" | "15"
205 : zone-day ( timestamp text -- timestamp' )
209 comparison-day-string
212 : string>year ( str -- year )
213 string>number <year-gmt> ;
215 : rule-year>years ( rule -- from to )
216 [ from>> ] [ to>> ] bi
218 { [ over "min" = ] [ [ drop -1/0. ] [ string>year ] bi* ] }
219 { [ dup "max" = ] [ [ string>year ] [ drop 1/0. ] bi* ] }
220 { [ dup "only" = ] [ drop dup [ string>year ] bi@ ] }
221 [ [ string>year ] bi@ ]
224 : parse-hms ( str -- hms-seq )
225 ":" split [ string>number ] map 3 0 pad-tail ;
227 : parse-offset ( str -- hms-seq )
228 "-" ?head [ parse-hms ] dip [ [ neg ] map ] when ;
230 ! XXX: Don't just drop the s/u, e.g. 2:00:00s
231 : zone-time ( timestamp time -- timestamp' )
232 [ Letter? ] split-tail drop
233 parse-offset first3 set-time ;
235 : hm>duration ( str -- duration )
236 ":" split1 "0" or [ string>number ] bi@
237 [ instant ] 2dip 0 set-time ;
239 : rule>timestamp-rest ( timestamp zone -- from )
241 [ over fp-infinity? [ drop ] [ in>> month-abbreviation-index >>month ] if ]
242 [ over fp-infinity? [ drop ] [ on>> zone-day ] if ]
243 [ over fp-infinity? [ drop ] [ at-time>> zone-time ] if ]
246 : rule>timestamps ( zone -- from to )
247 [ rule-year>years ] keep
248 [ nip rule>timestamp-rest ]
249 [ nipd rule>timestamp-rest ] 3bi ;
251 : until>timestamp ( seq -- unix-time )
253 4 f pad-tail first4 {
254 [ string>number <year-gmt> ]
255 [ [ zone-month ] when* ]
256 [ [ zone-day ] when* ]
257 [ [ zone-time ] when* ]
258 } spread timestamp>unix-time
261 : zones>interval-map ( zones -- interval-map )
263 [ until>> until>timestamp ] map
264 -1/0. prefix 2 <clumps> [ >array ] map
266 [ first2 1 - 2array ] map-keys <interval-map> ;
268 : name>zones ( name -- interval-map )
269 raw-zone-map at zones>interval-map ;
271 : gmt-offset ( timestamp name -- gmt-offset )
272 [ timestamp>unix-time ]
273 [ zones>interval-map ] bi* interval-at ;
275 : name>rules ( name -- rules )
278 [ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
279 [ [ save>> hm>duration ] [ letters>> ] bi 2array ] bi 2array
283 : chicago-zones ( -- interval-map ) "America/Chicago" name>zones ;
284 : us-rules ( -- rules ) "US" name>rules ;