extra/zoneinfo/zoneinfo.factor

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