1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ascii assocs calendar calendar.english
4 combinators combinators.smart io.encodings.utf8 io.files kernel
5 math.parser memoize namespaces sequences sequences.extras
6 sorting splitting splitting.extras ;
9 CONSTANT: zoneinfo-paths
11 "vocab:zoneinfo/africa"
12 "vocab:zoneinfo/antarctica"
14 "vocab:zoneinfo/australasia"
15 "vocab:zoneinfo/europe"
16 "vocab:zoneinfo/northamerica"
17 "vocab:zoneinfo/pacificnew"
18 "vocab:zoneinfo/southamerica"
19 "vocab:zoneinfo/etcetera"
20 "vocab:zoneinfo/factory"
21 "vocab:zoneinfo/leapseconds"
22 "vocab:zoneinfo/systemv"
27 TUPLE: raw-zone name gmt-offset rules/save format until ;
28 TUPLE: raw-rule name from to type in on at-time save letters ;
29 TUPLE: raw-link from to ;
30 TUPLE: raw-leap year month day hms corr r/s ;
33 TUPLE: rule name from to at-time ;
35 : rule-to ( m string -- m n )
42 : parse-rule ( seq -- rule )
44 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
45 ] input<sequence raw-rule boa ;
47 : parse-link ( seq -- link )
49 { [ drop ] [ ] [ ] } spread
50 ] input<sequence raw-link boa ;
52 : parse-leap ( seq -- link )
54 { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
55 ] input<sequence raw-leap boa ;
57 : parse-zone ( seq -- zone )
64 } cleave raw-zone boa ;
66 : parse-partial-zone ( seq -- zone )
67 [ last-zone get name>> ] dip
73 } cleave raw-zone boa ;
75 : parse-line ( seq -- tuple )
78 { "rule" [ parse-rule ] }
79 { "link" [ parse-link ] }
80 { "leap" [ parse-leap ] }
81 { "zone" [ parse-zone dup last-zone set ] }
82 [ drop harvest parse-partial-zone ]
85 : parse-zoneinfo-file ( path -- seq )
87 [ "#" split1 drop ] map harvest
88 [ "\t " split harvest ] map harvest
89 [ [ parse-line ] map ] with-scope ;
91 MEMO: zoneinfo-files ( -- seq )
92 zoneinfo-paths [ parse-zoneinfo-file ] map ;
94 MEMO: zoneinfo-array ( -- seq )
95 zoneinfo-files concat ;
97 : raw-rule-map ( -- assoc )
98 zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
100 : raw-zone-map ( -- assoc )
101 zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
103 : zoneinfo-zones ( -- seq )
105 [ "/" swap subseq? ] partition
106 [ natural-sort ] bi@ append ;
108 GENERIC: zone-matches? ( string rule -- ? )
110 M: raw-rule zone-matches? name>> = ;
111 M: raw-link zone-matches? from>> = ;
112 M: raw-leap zone-matches? 2drop f ;
113 M: raw-zone zone-matches? name>> = ;
115 : find-rules ( string -- rules )
117 [ [ to>> "max" = ] filter ] assoc-map at ;
119 ERROR: zone-not-found name ;
121 : find-zone ( string -- zone )
123 [ last ] assoc-map ?at [ zone-not-found ] unless ;
125 : find-zone-rules ( string -- zone rules )
126 find-zone dup rules/save>> find-rules ;
128 : zone-abbrevs ( -- assoc )
130 find-zone-rules [ format>> ] dip
132 letters>> swap "%" split1 dup [ 1 tail ] when surround
136 : number>value ( n -- n' )
144 : on>value ( n -- n' )
145 ! "3", "Thu>=8" always >=, "lastFri"
147 { [ dup 3 swap ?nth CHAR: > = ] [
148 3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
150 { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
154 : zone-month ( timestamp month -- timestamp' )
155 month-abbreviation-index >>month ;
157 : zone-day ( timestamp day -- timestamp' )
159 { "Sun>=1" [ 0 sunday-of-month ] }
160 { "lastSun" [ last-sunday-of-month ] }
161 [ string>number >>day ]
164 ! XXX: Don't just drop the s/u, e.g. 2:00:00s
165 : zone-time ( timestamp time -- timestamp' )
166 [ Letter? ] split-tail drop
167 time>offset first3 set-time ;
169 : until>timestamp ( seq -- timestamp )
172 4 f pad-tail first4 {
173 [ string>number <year-gmt> ]
174 [ [ zone-month ] when* ]
175 [ [ zone-day ] when* ]
176 [ [ zone-time ] when* ]
180 : raw-rule>triple ( raw-rule -- quot )
182 [ from>> string>number ]
183 [ in>> month-abbreviation-index ]