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