! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ascii assocs assocs.extras calendar
calendar.english combinators combinators.short-circuit
-combinators.smart csv grouping interval-maps io.encodings.utf8
-io.files kernel math math.parser memoize namespaces sequences
-sequences.extras sorting splitting splitting.extras ;
+combinators.smart countries grouping interval-maps
+io.encodings.utf8 io.files kernel math math.parser namespaces
+sequences sequences.extras sorting splitting splitting.extras ;
QUALIFIED: sets
IN: zoneinfo
"vocab:zoneinfo/pacificnew"
"vocab:zoneinfo/southamerica"
"vocab:zoneinfo/backzone"
+ "vocab:zoneinfo/etcetera"
}
CONSTANT: zoneinfo-extra-paths
{
"vocab:zoneinfo/backward"
- "vocab:zoneinfo/etcetera"
"vocab:zoneinfo/factory"
"vocab:zoneinfo/leapseconds"
"vocab:zoneinfo/systemv"
: zoneinfo-lines ( path -- seq )
utf8 file-lines
- [
- { [ length 0 = ] [ "#" head? ] } 1||
- ] reject ;
+ [ { [ length 0 = ] [ "#" head? ] } 1|| ] reject
+ [ "#" split1-last drop ] map ;
TUPLE: zonetab codes lat lng tz comments ;
C: <zonetab> zonetab
+
MEMO: zoneinfo-country-zones ( -- seq )
"vocab:zoneinfo/zone1970.tab" zoneinfo-lines
[
zoneinfo-country-zones
[ [ codes>> ] [ tz>> ] bi [ 2array ] curry map ] map concat ;
-MEMO: tz>country-map ( -- alist )
- parse-zonetabs [ first ] collect-value-by ;
+: lookup-country-name ( seq -- seq' ) alpha-2 ?at drop ; inline
+: lookup-country-names ( seq -- seq' ) [ lookup-country-name ] map ;
+
+: timezone>country-map ( -- alist )
+ parse-zonetabs [ nip ] collect-key-by ;
-MEMO: country>tzs-map ( -- alist )
- parse-zonetabs [ second ] collect-key-by ;
+: country>timezones-map ( -- alist )
+ parse-zonetabs [ drop ] collect-value-by ;
-SYMBOL: last-zone
+: country-timezones-map ( -- alist )
+ country>timezones-map [ dup lookup-country-names zip ] map-values ;
TUPLE: raw-zone name gmt-offset rules/save format until ;
TUPLE: raw-rule name from to type in on at-time save letters ;
TUPLE: raw-link from to ;
TUPLE: raw-leap year month day hms corr r/s ;
-TUPLE: zone name ;
-TUPLE: rule name from to at-time ;
+! TUPLE: zone name ;
+! TUPLE: rule name from to at-time ;
-: rule-to ( m string -- m n )
- {
- { "only" [ dup ] }
- { "max" [ 1/0. ] }
- [ string>number ]
- } case ;
+! : rule-to ( m string -- m n )
+! {
+! { "only" [ dup ] }
+! { "max" [ 1/0. ] }
+! [ string>number ]
+! } case ;
: parse-rule ( seq -- rule )
[
[ 5 tail harvest ]
} cleave raw-zone boa ;
-: parse-partial-zone ( seq -- zone )
- [ last-zone get name>> ] dip
- {
+: parse-rest-of-zone ( prev seq -- zone )
+ [ name>> ] dip {
[ first ]
[ second ]
[ 2 swap nth ]
[ 3 tail harvest ]
} cleave raw-zone boa ;
-: parse-zoneinfo-line ( seq -- tuple )
+: parse-zoneinfo-line ( prev/f seq -- tuple )
dup first >lower
{
- { "rule" [ parse-rule ] }
- { "link" [ parse-link ] }
- { "leap" [ parse-leap ] }
- { "zone" [ parse-zone dup last-zone set ] }
- [ drop harvest parse-partial-zone ]
+ { "rule" [ nip parse-rule ] }
+ { "link" [ nip parse-link ] }
+ { "leap" [ nip parse-leap ] }
+ { "zone" [ nip parse-zone ] }
+ [ drop harvest parse-rest-of-zone ]
} case ;
: parse-zoneinfo-file ( path -- seq )
zoneinfo-lines
- [ "\t " split ] map
- [ parse-zoneinfo-line ] map ;
+ [ "\t " split harvest ] map harvest
+ [ parse-zoneinfo-line ] map-with-previous ;
MEMO: zoneinfo-files ( -- seq )
zoneinfo-paths [ parse-zoneinfo-file ] map ;
: zoneinfo-zones ( -- seq )
raw-zone-map keys
- [ "/" swap subseq? ] partition
+ [ "/" subseq-index? ] partition
[ natural-sort ] bi@ append ;
GENERIC: zone-matches? ( string rule -- ? )
M: raw-leap zone-matches? 2drop f ;
M: raw-zone zone-matches? name>> = ;
-: find-rules ( string -- rules )
+: find-rules ( country -- rules )
raw-rule-map
[ [ to>> "max" = ] filter ] assoc-map at ;
ERROR: zone-not-found name ;
-: find-zone ( string -- zone )
+: find-zone ( timezone -- zone )
raw-zone-map
[ last ] assoc-map ?at [ zone-not-found ] unless ;
-: find-zone-rules ( string -- zone rules )
+: timezone>rules ( timezone -- rules )
+ raw-zone-map at ;
+
+: find-zone-rules ( timezone -- zone rules )
find-zone dup rules/save>> find-rules ;
: zone-abbrevs ( -- assoc )
: comparison-day-string ( timestamp string -- timestamp )
{
- { [ ">=" over subseq? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
- { [ "<=" over subseq? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
+ { [ dup ">=" subseq-index? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
+ { [ dup "<=" subseq-index? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
[ string>number >>day ]
} cond ;
: string>year ( str -- year )
string>number <year-gmt> ;
-: rule-year>years ( rule -- from to )
+: rule-year>years ( raw-rule -- from to )
[ from>> ] [ to>> ] bi
{
{ [ over "min" = ] [ [ drop -1/0. ] [ string>year ] bi* ] }
":" split1 "0" or [ string>number ] bi@
[ instant ] 2dip 0 set-time ;
+: hms>duration ( str -- duration )
+ ":" split 3 "0" pad-tail
+ [ string>number ] map first3
+ [ instant ] 3dip set-time ;
+
: rule>timestamp-rest ( timestamp zone -- from )
{
[ over fp-infinity? [ drop ] [ in>> month-abbreviation-index >>month ] if ]
} spread timestamp>unix-time
] if-empty ;
-: zones>interval-map ( zones -- interval-map )
+: raw-zones>interval-map ( raw-zones -- interval-map )
[
[ until>> until>timestamp ] map
-1/0. prefix 2 <clumps> [ >array ] map
] keep zip
[ first2 1 - 2array ] map-keys <interval-map> ;
-: name>zones ( name -- interval-map )
- raw-zone-map at zones>interval-map ;
+: timezone>interval-map ( timezone-name -- interval-map )
+ raw-zone-map at raw-zones>interval-map ;
-: gmt-offset ( timestamp name -- gmt-offset )
+: gmt-offset ( timestamp timezone-name -- gmt-offset )
[ timestamp>unix-time ]
- [ zones>interval-map ] bi* interval-at ;
+ [ raw-zones>interval-map ] bi* interval-at ;
: name>rules ( name -- rules )
raw-rule-map at [
[
[ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
- [ [ save>> hm>duration ] [ letters>> ] bi 2array ] bi 2array
+ [ [ save>> hms>duration ] [ letters>> ] bi 2array ] bi 2array
] map
] keep zip ;
-: chicago-zones ( -- interval-map ) "America/Chicago" name>zones ;
+: chicago-zones ( -- interval-map ) "America/Chicago" timezone>interval-map ;
: us-rules ( -- rules ) "US" name>rules ;
+: us-timezones ( -- timezones )
+ country>timezones-map "US" of ;
+
+: puerto-rico-timezone-countries ( -- countries )
+ timezone>country-map "America/Puerto_Rico" of lookup-country-names ;
projects / factor.git / blobdiff