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.smart grouping
   5 interval-maps io.encodings.utf8 io.files kernel math math.parser
   6 memoize namespaces sequences sequences.extras sorting splitting
   7 splitting.extras ;
   8 IN: zoneinfo
   9
  10 CONSTANT: zoneinfo-paths
  11 {
  12     "vocab:zoneinfo/africa"
  13     "vocab:zoneinfo/antarctica"
  14     "vocab:zoneinfo/asia"
  15     "vocab:zoneinfo/australasia"
  16     "vocab:zoneinfo/europe"
  17     "vocab:zoneinfo/northamerica"
  18     "vocab:zoneinfo/pacificnew"
  19     "vocab:zoneinfo/southamerica"
  20     "vocab:zoneinfo/etcetera"
  21     "vocab:zoneinfo/factory"
  22     "vocab:zoneinfo/leapseconds"
  23     "vocab:zoneinfo/systemv"
  24 }
  25
  26 SYMBOL: last-zone
  27
  28 TUPLE: raw-zone name gmt-offset rules/save format until ;
  29 TUPLE: raw-rule name from to type in on at-time save letters ;
  30 TUPLE: raw-link from to ;
  31 TUPLE: raw-leap year month day hms corr r/s ;
  32
  33 TUPLE: zone name ;
  34 TUPLE: rule name from to at-time ;
  35
  36 : rule-to ( m string -- m n )
  37     {
  38         { "only" [ dup ] }
  39         { "max" [ 1/0. ] }
  40         [ string>number ]
  41     } case ;
  42
  43 : parse-rule ( seq -- rule )
  44     [
  45         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  46     ] input<sequence raw-rule boa ;
  47
  48 : parse-link ( seq -- link )
  49     [
  50         { [ drop ] [ ] [ ] } spread
  51     ] input<sequence raw-link boa ;
  52
  53 : parse-leap ( seq -- link )
  54     [
  55         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  56     ] input<sequence raw-leap boa ;
  57
  58 : parse-zone ( seq -- zone )
  59     {
  60         [ second ]
  61         [ third ]
  62         [ fourth ]
  63         [ 4 swap nth ]
  64         [ 5 tail harvest ]
  65     } cleave raw-zone boa ;
  66
  67 : parse-partial-zone ( seq -- zone )
  68     [ last-zone get name>> ] dip
  69     {
  70         [ first ]
  71         [ second ]
  72         [ 2 swap nth ]
  73         [ 3 tail harvest ]
  74     } cleave raw-zone boa ;
  75
  76 : parse-line ( seq -- tuple )
  77     dup first >lower
  78     {
  79         { "rule" [ parse-rule ] }
  80         { "link" [ parse-link ] }
  81         { "leap" [ parse-leap ] }
  82         { "zone" [ parse-zone dup last-zone set ] }
  83         [ drop harvest parse-partial-zone ]
  84     } case ;
  85
  86 : parse-zoneinfo-file ( path -- seq )
  87     utf8 file-lines
  88     [ "#" split1 drop ] map harvest
  89     [ "\t " split harvest ] map harvest
  90     [ [ parse-line ] map ] with-scope ;
  91
  92 MEMO: zoneinfo-files ( -- seq )
  93     zoneinfo-paths [ parse-zoneinfo-file ] map ;
  94
  95 MEMO: zoneinfo-array ( -- seq )
  96     zoneinfo-files concat ;
  97
  98 : raw-rule-map ( -- assoc )
  99     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
 100
 101 : raw-zone-map ( -- assoc )
 102     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 103
 104 : zoneinfo-zones ( -- seq )
 105     raw-zone-map keys
 106     [ "/" swap subseq? ] partition
 107     [ natural-sort ] bi@ append ;
 108
 109 GENERIC: zone-matches? ( string rule -- ? )
 110
 111 M: raw-rule zone-matches? name>> = ;
 112 M: raw-link zone-matches? from>> = ;
 113 M: raw-leap zone-matches? 2drop f ;
 114 M: raw-zone zone-matches? name>> = ;
 115
 116 : find-rules ( string -- rules )
 117     raw-rule-map
 118     [ [ to>> "max" = ] filter ] assoc-map at ;
 119
 120 ERROR: zone-not-found name ;
 121
 122 : find-zone ( string -- zone )
 123     raw-zone-map
 124     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 125
 126 : find-zone-rules ( string -- zone rules )
 127     find-zone dup rules/save>> find-rules ;
 128
 129 : zone-abbrevs ( -- assoc )
 130     zoneinfo-zones [
 131         find-zone-rules [ format>> ] dip
 132         [
 133             letters>> swap "%" split1 dup [ 1 tail ] when surround
 134         ] with V{ } map-as
 135     ] map-zip ;
 136
 137 : number>value ( n -- n' )
 138     {
 139         { "only" [ f ] }
 140         { "min" [ f ] }
 141         { "max" [ t ] }
 142         [ string>number ]
 143     } case ;
 144
 145 : on>value ( n -- n' )
 146     ! "3", "Thu>=8" always >=, "lastFri"
 147     {
 148         { [ dup 3 swap ?nth CHAR: > = ] [
 149             3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
 150         ] }
 151         { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
 152         [ string>number ]
 153     } cond ;
 154
 155 : zone-month ( timestamp month -- timestamp' )
 156     month-abbreviation-index >>month ;
 157
 158 ERROR: unknown-day-abbrev day ;
 159 : day-abbrev>= ( timestamp day -- timestamp' )
 160     {
 161         { "Sun" [ sunday>= ] }
 162         { "Mon" [ monday>= ] }
 163         { "Tue" [ tuesday>= ] }
 164         { "Wed" [ wednesday>= ] }
 165         { "Thu" [ thursday>= ] }
 166         { "Fri" [ friday>= ] }
 167         { "Sat" [ saturday>= ] }
 168         [ unknown-day-abbrev ]
 169     } case ;
 170
 171 : day-abbrev<= ( timestamp day -- timestamp' )
 172     {
 173         { "Sun" [ sunday<= ] }
 174         { "Mon" [ monday<= ] }
 175         { "Tue" [ tuesday<= ] }
 176         { "Wed" [ wednesday<= ] }
 177         { "Thu" [ thursday<= ] }
 178         { "Fri" [ friday<= ] }
 179         { "Sat" [ saturday<= ] }
 180         [ unknown-day-abbrev ]
 181     } case ;
 182
 183 : comparison-day-string ( timestamp string -- timestamp )
 184     {
 185         { [ ">=" over subseq? ] [ ">=" split1 swap [ string>number >>day ] dip day-abbrev>= ] }
 186         { [ "<=" over subseq? ] [ "<=" split1 swap [ string>number >>day ] dip day-abbrev<= ] }
 187         [ string>number >>day ]
 188     } cond ;
 189
 190 ERROR: unknown-last-day string ;
 191
 192 : last-day-string ( timestamp string -- timestamp )
 193     {
 194         { "lastSun" [ last-sunday-of-month ] }
 195         { "lastMon" [ last-monday-of-month ] }
 196         { "lastTue" [ last-tuesday-of-month ] }
 197         { "lastWed" [ last-wednesday-of-month ] }
 198         { "lastThu" [ last-thursday-of-month ] }
 199         { "lastFri" [ last-friday-of-month ] }
 200         { "lastSat" [ last-saturday-of-month ] }
 201         [ unknown-last-day ]
 202     } case ;
 203
 204 !  "lastFri" | "Fri<=1" | "Sat>=2" | "15"
 205 : zone-day ( timestamp text -- timestamp' )
 206     dup "last" head? [
 207         last-day-string
 208     ] [
 209         comparison-day-string
 210     ] if ;
 211
 212 : string>year ( str -- year )
 213     string>number <year-gmt> ;
 214
 215 : rule-year>years ( rule -- from to )
 216     [ from>> ] [ to>> ] bi
 217     {
 218         { [ over "min" = ] [ [ drop -1/0. ] [ string>year ] bi* ] }
 219         { [ dup "max" = ] [ [ string>year ] [ drop 1/0. ] bi* ] }
 220         { [ dup "only" = ] [ drop dup [ string>year ] bi@ ] }
 221         [ [ string>year ] bi@ ]
 222     } cond ;
 223
 224 : parse-hms ( str -- hms-seq )
 225     ":" split [ string>number ] map 3 0 pad-tail ;
 226
 227 : parse-offset ( str -- hms-seq )
 228     "-" ?head [ parse-hms ] dip [ [ neg ] map ] when ;
 229
 230 ! XXX: Don't just drop the s/u, e.g. 2:00:00s
 231 : zone-time ( timestamp time -- timestamp' )
 232     [ Letter? ] split-tail drop
 233     parse-offset first3 set-time ;
 234
 235 : hm>duration ( str -- duration )
 236     ":" split1 "0" or [ string>number ] bi@
 237     [ instant ] 2dip 0 set-time ;
 238
 239 : rule>timestamp-rest ( timestamp zone -- from )
 240     {
 241         [ over fp-infinity? [ drop ] [ in>> month-abbreviation-index >>month ] if ]
 242         [ over fp-infinity? [ drop ] [ on>> zone-day ] if ]
 243         [ over fp-infinity? [ drop ] [ at-time>> zone-time ] if ]
 244     } cleave ;
 245
 246 : rule>timestamps ( zone -- from to )
 247     [ rule-year>years ] keep
 248     [ nip rule>timestamp-rest ]
 249     [ nipd rule>timestamp-rest ] 3bi ;
 250
 251 : until>timestamp ( seq -- unix-time )
 252     [ 1/0. ] [
 253         4 f pad-tail first4 {
 254             [ string>number <year-gmt> ]
 255             [ [ zone-month ] when* ]
 256             [ [ zone-day ] when* ]
 257             [ [ zone-time ] when* ]
 258         } spread timestamp>unix-time
 259     ] if-empty ;
 260
 261 : zones>interval-map ( zones -- interval-map )
 262     [
 263         [ until>> until>timestamp ] map
 264         -1/0. prefix 2 <clumps> [ >array ] map
 265     ] keep zip
 266     [ first2 1 - 2array ] map-keys <interval-map> ;
 267
 268 : name>zones ( name -- interval-map )
 269     raw-zone-map at zones>interval-map ;
 270
 271 : gmt-offset ( timestamp name -- gmt-offset )
 272     [ timestamp>unix-time ]
 273     [ zones>interval-map ] bi* interval-at ;
 274
 275 : name>rules ( name -- rules )
 276     raw-rule-map at [
 277         [
 278             [ rule>timestamps [ dup fp-infinity? [ timestamp>unix-time ] unless ] bi@ 2array ]
 279             [ [ save>> hm>duration ] [ letters>> ] bi 2array ] bi 2array
 280         ] map
 281     ] keep zip ;
 282
 283 : chicago-zones ( -- interval-map ) "America/Chicago" name>zones ;
 284  : us-rules ( -- rules ) "US" name>rules ;