extra/zoneinfo/zoneinfo.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar.english combinators
   4 combinators.smart io.encodings.utf8 io.files kernel math.parser
   5 memoize namespaces sequences sorting splitting unicode ;
   6 IN: zoneinfo
   7
   8 CONSTANT: zoneinfo-paths
   9 {
  10     "vocab:zoneinfo/africa"
  11     "vocab:zoneinfo/antarctica"
  12     "vocab:zoneinfo/asia"
  13     "vocab:zoneinfo/australasia"
  14     "vocab:zoneinfo/europe"
  15     "vocab:zoneinfo/northamerica"
  16     "vocab:zoneinfo/pacificnew"
  17     "vocab:zoneinfo/southamerica"
  18     "vocab:zoneinfo/etcetera"
  19     "vocab:zoneinfo/factory"
  20     "vocab:zoneinfo/leapseconds"
  21     "vocab:zoneinfo/systemv"
  22 }
  23
  24 SYMBOL: last-zone
  25
  26 TUPLE: raw-zone name gmt-offset rules/save format until ;
  27 TUPLE: raw-rule name from to type in on at-time save letters ;
  28 TUPLE: raw-link from to ;
  29 TUPLE: raw-leap year month day hms corr r/s ;
  30
  31 TUPLE: zone name ;
  32 TUPLE: rule name from to at-time ;
  33
  34 : rule-to ( m string -- m n )
  35     {
  36         { "only" [ dup ] }
  37         { "max" [ 1/0. ] }
  38         [ string>number ]
  39     } case ;
  40
  41 : parse-rule ( seq -- rule )
  42     [
  43         {
  44             [ drop ]
  45             [ ]
  46             [ ]
  47             [ ]
  48             [ ]
  49             [ ]
  50             [ ]
  51             [ ]
  52             [ ]
  53             [ ]
  54         } spread
  55     ] input<sequence raw-rule boa ;
  56
  57 : parse-zone ( seq -- zone )
  58     {
  59         [ second ]
  60         [ third ]
  61         [ fourth ]
  62         [ 4 swap nth ]
  63         [ 5 tail harvest ]
  64     } cleave raw-zone boa ;
  65
  66 : parse-partial-zone ( seq -- zone )
  67     [ last-zone get name>> ] dip
  68     {
  69         [ first ]
  70         [ second ]
  71         [ 2 swap nth ]
  72         [ 3 tail harvest ]
  73     } cleave raw-zone boa ;
  74
  75 : parse-link ( seq -- link )
  76     [
  77         {
  78             [ drop ]
  79             [ ]
  80             [ ]
  81         } spread
  82     ] input<sequence raw-link boa ;
  83
  84 : parse-leap ( seq -- link )
  85     [
  86         {
  87             [ drop ]
  88             [ ]
  89             [ ]
  90             [ ]
  91             [ ]
  92             [ ]
  93             [ ]
  94         } spread
  95     ] input<sequence raw-leap boa ;
  96
  97 : parse-line ( seq -- tuple )
  98     dup first >lower
  99     {
 100         { "zone" [ parse-zone dup last-zone set ] }
 101         { "rule" [ parse-rule ] }
 102         { "link" [ parse-link ] }
 103         { "leap" [ parse-leap ] }
 104         [ drop harvest parse-partial-zone ]
 105     } case ;
 106
 107 : parse-zoneinfo-file ( path -- seq )
 108     utf8 file-lines
 109     [ "#" split1 drop ] map harvest
 110     [ "\t " split harvest ] map harvest
 111     [ [ parse-line ] map ] with-scope ;
 112
 113 MEMO: zoneinfo-files ( -- seq )
 114     zoneinfo-paths [ parse-zoneinfo-file ] map ;
 115
 116 MEMO: zoneinfo-array ( -- seq )
 117     zoneinfo-files concat ;
 118
 119 : raw-rule-map ( -- assoc )
 120     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
 121
 122 : raw-zone-map ( -- assoc )
 123     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 124
 125 : zoneinfo-zones ( -- seq )
 126     raw-zone-map keys
 127     [ "/" swap subseq? ] partition
 128     [ natural-sort ] bi@ append ;
 129
 130 GENERIC: zone-matches? ( string rule -- ? )
 131
 132 M: raw-rule zone-matches? name>> = ;
 133 M: raw-zone zone-matches? name>> = ;
 134 M: raw-link zone-matches? from>> = ;
 135 M: raw-leap zone-matches? 2drop f ;
 136
 137 : find-rules ( string -- rules )
 138     raw-rule-map
 139     [ [ to>> "max" = ] filter ] assoc-map at ;
 140
 141 ERROR: zone-not-found name ;
 142
 143 : find-zone ( string -- rules )
 144     raw-zone-map
 145     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 146
 147 : find-zone-rules ( string -- zone rules )
 148     find-zone dup rules/save>> find-rules ;
 149
 150 : number>value ( n -- n' )
 151     {
 152         { "only" [ f ] }
 153         { "min" [ f ] }
 154         { "max" [ t ] }
 155         [ string>number ]
 156     } case ;
 157
 158 : on>value ( n -- n' )
 159     ! "3", "Thu>=8" always >=, "lastFri"
 160     {
 161         { [ dup 3 swap ?nth CHAR: > = ] [
 162             3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
 163         ] }
 164         { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
 165         [ string>number ]
 166     } cond ;
 167
 168 : raw-rule>triple ( raw-rule -- quot )
 169     {
 170         [ from>> string>number ]
 171         [ in>> month-abbreviation-index ]
 172         [ on>> on>value ]
 173     } cleave>array ;
 174
 175 ! "Europe/Helsinki" find-zone-rules
 176
 177 ! Rule
 178 ! name - string
 179 ! from - year or "min"
 180 ! name    "France"
 181 ! from    "1938"  or "min"
 182 ! to      "1945" or "max" or "only"
 183 ! type    "-"  always "-"
 184 ! in      "Mar"  -- 3-letter month name
 185 ! on      "26"  or "Mon>=15"  or lastSun lastFri
 186 ! at      "23:00s"  "12:13:00s" "1:00s" "1:00u"
 187 ! save    "-0:00:05" "1:00" "0:14:15"
 188 ! letters "S" or "-" or "AMT" "BDST"
 189
 190 ! Zone
 191 ! name       "Indian/Maldives"
 192 ! gmt-offset "4:54:00" "9:55:56" "-9:55:56"
 193 ! rules/save "-" "0:20" "0:30" "1:00" "AN" "W-Eur" "Winn" "Zion" "sol87" "sol88"
 194 ! format     "LMT" "%s" "%sT" "A%sT" "AC%sT" "ACT"
 195 ! until      { "1880" }
 196     ! { "1847" "Dec" "1" "0:00s" }
 197     ! { "1883" "Nov" "18" "12:12:57" }
 198     ! { "1989" "Sep" "lastSun" "2:00s" }
 199
 200 ! Link
 201 ! T{ link { from "Asia/Riyadh88" } { to "Mideast/Riyadh88" } }