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     "vocab:zoneinfo/etcetera"
  23 }
  24
  25 CONSTANT: zoneinfo-extra-paths
  26 {
  27     "vocab:zoneinfo/backward"
  28     "vocab:zoneinfo/factory"
  29     "vocab:zoneinfo/leapseconds"
  30     "vocab:zoneinfo/systemv"
  31 }
  32
  33 : zoneinfo-lines ( path -- seq )
  34     utf8 file-lines
  35     [ { [ length 0 = ] [ "#" head? ] } 1|| ] reject
  36     [ "#" split1-last drop ] map ;
  37
  38 TUPLE: zonetab codes lat lng tz comments ;
  39 C: <zonetab> zonetab
  40
  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 [ nip ] collect-key-by ;
  59
  60 : country>timezones-map ( -- alist )
  61     parse-zonetabs [ drop ] collect-value-by ;
  62
  63 : country-timezones-map ( -- alist )
  64     country>timezones-map [ dup lookup-country-names zip ] map-values ;
  65
  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 ;
  70
  71 ! TUPLE: zone name ;
  72 ! TUPLE: rule name from to at-time ;
  73
  74 ! : rule-to ( m string -- m n )
  75 !     {
  76 !         { "only" [ dup ] }
  77 !         { "max" [ 1/0. ] }
  78 !         [ string>number ]
  79 !     } case ;
  80
  81 : parse-rule ( seq -- rule )
  82     [
  83         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  84     ] input<sequence raw-rule boa ;
  85
  86 : parse-link ( seq -- link )
  87     [
  88         { [ drop ] [ ] [ ] } spread
  89     ] input<sequence raw-link boa ;
  90
  91 : parse-leap ( seq -- link )
  92     [
  93         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  94     ] input<sequence raw-leap boa ;
  95
  96 : parse-zone ( seq -- zone )
  97     {
  98         [ second ]
  99         [ third ]
 100         [ fourth ]
 101         [ 4 swap nth ]
 102         [ 5 tail harvest ]
 103     } cleave raw-zone boa ;
 104
 105 : parse-rest-of-zone ( prev seq -- zone )
 106     [ name>> ] dip {
 107         [ first ]
 108         [ second ]
 109         [ 2 swap nth ]
 110         [ 3 tail harvest ]
 111     } cleave raw-zone boa ;
 112
 113 : parse-zoneinfo-line ( prev/f seq -- tuple )
 114     dup first >lower
 115     {
 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 ]
 121     } case ;
 122
 123 : parse-zoneinfo-file ( path -- seq )
 124     zoneinfo-lines
 125     [ "\t " split harvest ] map harvest
 126     [ parse-zoneinfo-line ] map-with-previous ;
 127
 128 MEMO: zoneinfo-files ( -- seq )
 129     zoneinfo-paths [ parse-zoneinfo-file ] map ;
 130
 131 MEMO: zoneinfo-array ( -- seq )
 132     zoneinfo-files concat ;
 133
 134 MEMO: zoneinfo-assoc ( -- assoc )
 135     zoneinfo-paths [ dup parse-zoneinfo-file ] { } map>assoc ;
 136
 137 : raw-rule-map ( -- assoc )
 138     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
 139
 140 : current-rule-map ( -- assoc )
 141     raw-rule-map
 142     [ [ to>> "max" = ] filter ] assoc-map
 143     harvest-values ;
 144
 145 : raw-zone-map ( -- assoc )
 146     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 147
 148 : zoneinfo-zones ( -- seq )
 149     raw-zone-map keys
 150     [ "/" subseq-index? ] partition
 151     [ natural-sort ] bi@ append ;
 152
 153 GENERIC: zone-matches? ( string rule -- ? )
 154
 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>> = ;
 159
 160 : find-rules ( country -- rules )
 161     raw-rule-map
 162     [ [ to>> "max" = ] filter ] assoc-map at ;
 163
 164 ERROR: zone-not-found name ;
 165
 166 : find-zone ( timezone -- zone )
 167     raw-zone-map
 168     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 169
 170 : timezone>rules ( timezone -- rules )
 171     raw-zone-map at ;
 172
 173 : find-zone-rules ( timezone -- 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         { [ dup ">=" subseq-index? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
 236         { [ dup "<=" subseq-index? ] [ "<=" 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 ( raw-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 : hms>duration ( str -- duration )
 290     ":" split 3 "0" pad-tail
 291     [ string>number ] map first3
 292     [ instant ] 3dip set-time ;
 293
 294 : rule>timestamp-rest ( timestamp zone -- from )
 295     {
 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 ]
 299     } cleave ;
 300
 301 : rule>timestamps ( zone -- from to )
 302     [ rule-year>years ] keep
 303     [ nip rule>timestamp-rest ]
 304     [ nipd rule>timestamp-rest ] 3bi ;
 305
 306 : until>timestamp ( seq -- unix-time )
 307     [ 1/0. ] [
 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
 314     ] if-empty ;
 315
 316 : raw-zones>interval-map ( raw-zones -- interval-map )
 317     [
 318         [ until>> until>timestamp ] map
 319         -1/0. prefix 2 <clumps> [ >array ] map
 320     ] keep zip
 321     [ first2 1 - 2array ] map-keys <interval-map> ;
 322
 323 : timezone>interval-map ( timezone-name -- interval-map )
 324     raw-zone-map at raw-zones>interval-map ;
 325
 326 : gmt-offset ( timestamp timezone-name -- gmt-offset )
 327     [ timestamp>unix-time ]
 328     [ raw-zones>interval-map ] bi* interval-at ;
 329
 330 : name>rules ( name -- rules )
 331     raw-rule-map at [
 332         [
 333             [ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
 334             [ [ save>> hms>duration ] [ letters>> ] bi 2array ] bi 2array
 335         ] map
 336     ] keep zip ;
 337
 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 ;
 342
 343 : puerto-rico-timezone-countries ( -- countries )
 344     timezone>country-map "America/Puerto_Rico" of lookup-country-names ;