extra/zoneinfo/zoneinfo.factor

   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 ;
   8 QUALIFIED: sets
   9 IN: zoneinfo
  10
  11 CONSTANT: zoneinfo-paths
  12 {
  13     "vocab:zoneinfo/africa"
  14     "vocab:zoneinfo/antarctica"
  15     "vocab:zoneinfo/asia"
  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 }
  23
  24 CONSTANT: zoneinfo-extra-paths
  25 {
  26     "vocab:zoneinfo/backward"
  27     "vocab:zoneinfo/etcetera"
  28     "vocab:zoneinfo/factory"
  29     "vocab:zoneinfo/leapseconds"
  30     "vocab:zoneinfo/systemv"
  31 }
  32
  33 : zoneinfo-lines ( path -- seq )
  34     utf8 file-lines
  35     [
  36         { [ length 0 = ] [ "#" head? ] } 1||
  37     ] reject ;
  38
  39 TUPLE: zonetab codes lat lng tz comments ;
  40 C: <zonetab> zonetab
  41 MEMO: zoneinfo-country-zones ( -- seq )
  42     "vocab:zoneinfo/zone1970.tab" zoneinfo-lines
  43     [
  44         "\t" split ?first4
  45         [ "," split ] 3dip
  46         [ "-+" split* first4 [ append ] 2dip append ] 2dip
  47         <zonetab>
  48     ] { } map-as ;
  49
  50 : parse-zonetabs ( -- seq )
  51     zoneinfo-country-zones
  52     [ [ codes>> ] [ tz>> ] bi [ 2array ] curry map ] map concat ;
  53
  54 : lookup-country-name ( seq -- seq' ) alpha-2 ?at drop ; inline
  55 : lookup-country-names ( seq -- seq' ) [ lookup-country-name ] map ;
  56
  57 : timezone>country-map ( -- alist )
  58     parse-zonetabs [ second ] collect-key-by ;
  59
  60 : country>timezones-map ( -- alist )
  61     parse-zonetabs [ first ] collect-value-by ;
  62
  63 : country-timezones-map ( -- alist )
  64     country>timezones-map [ dup lookup-country-names zip ] map-values ;
  65
  66 SYMBOL: last-zone
  67
  68 TUPLE: raw-zone name gmt-offset rules/save format until ;
  69 TUPLE: raw-rule name from to type in on at-time save letters ;
  70 TUPLE: raw-link from to ;
  71 TUPLE: raw-leap year month day hms corr r/s ;
  72
  73 TUPLE: zone name ;
  74 TUPLE: rule name from to at-time ;
  75
  76 : rule-to ( m string -- m n )
  77     {
  78         { "only" [ dup ] }
  79         { "max" [ 1/0. ] }
  80         [ string>number ]
  81     } case ;
  82
  83 : parse-rule ( seq -- rule )
  84     [
  85         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  86     ] input<sequence raw-rule boa ;
  87
  88 : parse-link ( seq -- link )
  89     [
  90         { [ drop ] [ ] [ ] } spread
  91     ] input<sequence raw-link boa ;
  92
  93 : parse-leap ( seq -- link )
  94     [
  95         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  96     ] input<sequence raw-leap boa ;
  97
  98 : parse-zone ( seq -- zone )
  99     {
 100         [ second ]
 101         [ third ]
 102         [ fourth ]
 103         [ 4 swap nth ]
 104         [ 5 tail harvest ]
 105     } cleave raw-zone boa ;
 106
 107 : parse-partial-zone ( seq -- zone )
 108     [ last-zone get name>> ] dip
 109     {
 110         [ first ]
 111         [ second ]
 112         [ 2 swap nth ]
 113         [ 3 tail harvest ]
 114     } cleave raw-zone boa ;
 115
 116 : parse-zoneinfo-line ( seq -- tuple )
 117     dup first >lower
 118     {
 119         { "rule" [ parse-rule ] }
 120         { "link" [ parse-link ] }
 121         { "leap" [ parse-leap ] }
 122         { "zone" [ parse-zone dup last-zone set ] }
 123         [ drop harvest parse-partial-zone ]
 124     } case ;
 125
 126 : parse-zoneinfo-file ( path -- seq )
 127     zoneinfo-lines
 128     [ "\t " split harvest ] map harvest
 129     [ parse-zoneinfo-line ] map ;
 130
 131 MEMO: zoneinfo-files ( -- seq )
 132     zoneinfo-paths [ parse-zoneinfo-file ] map ;
 133
 134 MEMO: zoneinfo-array ( -- seq )
 135     zoneinfo-files concat ;
 136
 137 MEMO: zoneinfo-assoc ( -- assoc )
 138     zoneinfo-paths [ dup parse-zoneinfo-file ] { } map>assoc ;
 139
 140 : raw-rule-map ( -- assoc )
 141     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
 142
 143 : current-rule-map ( -- assoc )
 144     raw-rule-map
 145     [ [ to>> "max" = ] filter ] assoc-map
 146     harvest-values ;
 147
 148 : raw-zone-map ( -- assoc )
 149     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 150
 151 : zoneinfo-zones ( -- seq )
 152     raw-zone-map keys
 153     [ "/" swap subseq? ] partition
 154     [ natural-sort ] bi@ append ;
 155
 156 GENERIC: zone-matches? ( string rule -- ? )
 157
 158 M: raw-rule zone-matches? name>> = ;
 159 M: raw-link zone-matches? from>> = ;
 160 M: raw-leap zone-matches? 2drop f ;
 161 M: raw-zone zone-matches? name>> = ;
 162
 163 : find-rules ( string -- rules )
 164     raw-rule-map
 165     [ [ to>> "max" = ] filter ] assoc-map at ;
 166
 167 ERROR: zone-not-found name ;
 168
 169 : find-zone ( string -- zone )
 170     raw-zone-map
 171     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 172
 173 : find-zone-rules ( string -- zone rules )
 174     find-zone dup rules/save>> find-rules ;
 175
 176 : zone-abbrevs ( -- assoc )
 177     zoneinfo-zones [
 178         find-zone-rules
 179         [ format>> ] dip
 180         [
 181             letters>> dup { "D" "S" } member? [ drop "" ] unless
 182             swap "%" split1
 183             [ 1 tail surround ] [ nip ] if*
 184         ] with V{ } map-as sets:members
 185     ] zip-with ;
 186
 187 : number>value ( n -- n' )
 188     {
 189         { "only" [ f ] }
 190         { "min" [ f ] }
 191         { "max" [ t ] }
 192         [ string>number ]
 193     } case ;
 194
 195 : on>value ( n -- n' )
 196     ! "3", "Thu>=8" always >=, "lastFri"
 197     {
 198         { [ dup 3 swap ?nth CHAR: > = ] [
 199             3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
 200         ] }
 201         { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
 202         [ string>number ]
 203     } cond ;
 204
 205 : zone-month ( timestamp month -- timestamp' )
 206     month-abbreviation-index >>month ;
 207
 208 ERROR: unknown-day-abbrev day ;
 209 : day-abbrev>= ( timestamp day -- timestamp' )
 210     {
 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 ]
 219     } case ;
 220
 221 : day-abbrev<= ( timestamp day -- timestamp' )
 222     {
 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 ]
 231     } case ;
 232
 233 : comparison-day-string ( timestamp string -- timestamp )
 234     {
 235         { [ ">=" over subseq? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
 236         { [ "<=" over subseq? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
 237         [ string>number >>day ]
 238     } cond ;
 239
 240 ERROR: unknown-last-day string ;
 241
 242 : last-day-string ( timestamp string -- timestamp )
 243     {
 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 ] }
 251         [ unknown-last-day ]
 252     } case ;
 253
 254 !  "lastFri" | "Fri<=1" | "Sat>=2" | "15"
 255 : zone-day ( timestamp text -- timestamp' )
 256     dup "last" head? [
 257         last-day-string
 258     ] [
 259         comparison-day-string
 260     ] if ;
 261
 262 : string>year ( str -- year )
 263     string>number <year-gmt> ;
 264
 265 : rule-year>years ( rule -- from to )
 266     [ from>> ] [ to>> ] bi
 267     {
 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@ ]
 272     } cond ;
 273
 274 : parse-hms ( str -- hms-seq )
 275     ":" split [ string>number ] map 3 0 pad-tail ;
 276
 277 : parse-offset ( str -- hms-seq )
 278     "-" ?head [ parse-hms ] dip [ [ neg ] map ] when ;
 279
 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 ;
 284
 285 : hm>duration ( str -- duration )
 286     ":" split1 "0" or [ string>number ] bi@
 287     [ instant ] 2dip 0 set-time ;
 288
 289 : rule>timestamp-rest ( timestamp zone -- from )
 290     {
 291         [ over fp-infinity? [ drop ] [ in>> month-abbreviation-index >>month ] if ]
 292         [ over fp-infinity? [ drop ] [ on>> zone-day ] if ]
 293         [ over fp-infinity? [ drop ] [ at-time>> zone-time ] if ]
 294     } cleave ;
 295
 296 : rule>timestamps ( zone -- from to )
 297     [ rule-year>years ] keep
 298     [ nip rule>timestamp-rest ]
 299     [ nipd rule>timestamp-rest ] 3bi ;
 300
 301 : until>timestamp ( seq -- unix-time )
 302     [ 1/0. ] [
 303         4 f pad-tail first4 {
 304             [ string>number <year-gmt> ]
 305             [ [ zone-month ] when* ]
 306             [ [ zone-day ] when* ]
 307             [ [ zone-time ] when* ]
 308         } spread timestamp>unix-time
 309     ] if-empty ;
 310
 311 : zones>interval-map ( zones -- interval-map )
 312     [
 313         [ until>> until>timestamp ] map
 314         -1/0. prefix 2 <clumps> [ >array ] map
 315     ] keep zip
 316     [ first2 1 - 2array ] map-keys <interval-map> ;
 317
 318 : name>zones ( name -- interval-map )
 319     raw-zone-map at zones>interval-map ;
 320
 321 : gmt-offset ( timestamp name -- gmt-offset )
 322     [ timestamp>unix-time ]
 323     [ zones>interval-map ] bi* interval-at ;
 324
 325 : name>rules ( name -- rules )
 326     raw-rule-map at [
 327         [
 328             [ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
 329             [ [ save>> hm>duration ] [ letters>> ] bi 2array ] bi 2array
 330         ] map
 331     ] keep zip ;
 332
 333 : chicago-zones ( -- interval-map ) "America/Chicago" name>zones ;
 334 : us-rules ( -- rules ) "US" name>rules ;
 335
 336 : us-timezones ( -- timezones )
 337     country>timezones-map "US" of ;
 338
 339 : puerto-rico-timezone-countries ( -- countries )
 340     timezone>country-map "America/Puerto_Rico" of ;