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 sequences.extras sorting splitting
   6 unicode ;
   7 IN: zoneinfo
   8
   9 CONSTANT: zoneinfo-paths
  10 {
  11     "vocab:zoneinfo/africa"
  12     "vocab:zoneinfo/antarctica"
  13     "vocab:zoneinfo/asia"
  14     "vocab:zoneinfo/australasia"
  15     "vocab:zoneinfo/europe"
  16     "vocab:zoneinfo/northamerica"
  17     "vocab:zoneinfo/pacificnew"
  18     "vocab:zoneinfo/southamerica"
  19     "vocab:zoneinfo/etcetera"
  20     "vocab:zoneinfo/factory"
  21     "vocab:zoneinfo/leapseconds"
  22     "vocab:zoneinfo/systemv"
  23 }
  24
  25 SYMBOL: last-zone
  26
  27 TUPLE: raw-zone name gmt-offset rules/save format until ;
  28 TUPLE: raw-rule name from to type in on at-time save letters ;
  29 TUPLE: raw-link from to ;
  30 TUPLE: raw-leap year month day hms corr r/s ;
  31
  32 TUPLE: zone name ;
  33 TUPLE: rule name from to at-time ;
  34
  35 : rule-to ( m string -- m n )
  36     {
  37         { "only" [ dup ] }
  38         { "max" [ 1/0. ] }
  39         [ string>number ]
  40     } case ;
  41
  42 : parse-rule ( seq -- rule )
  43     [
  44         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  45     ] input<sequence raw-rule boa ;
  46
  47 : parse-link ( seq -- link )
  48     [
  49         { [ drop ] [ ] [ ] } spread
  50     ] input<sequence raw-link boa ;
  51
  52 : parse-leap ( seq -- link )
  53     [
  54         { [ drop ] [ ] [ ] [ ] [ ] [ ] [ ] } spread
  55     ] input<sequence raw-leap 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-line ( seq -- tuple )
  76     dup first >lower
  77     {
  78         { "rule" [ parse-rule ] }
  79         { "link" [ parse-link ] }
  80         { "leap" [ parse-leap ] }
  81         { "zone" [ parse-zone dup last-zone set ] }
  82         [ drop harvest parse-partial-zone ]
  83     } case ;
  84
  85 : parse-zoneinfo-file ( path -- seq )
  86     utf8 file-lines
  87     [ "#" split1 drop ] map harvest
  88     [ "\t " split harvest ] map harvest
  89     [ [ parse-line ] map ] with-scope ;
  90
  91 MEMO: zoneinfo-files ( -- seq )
  92     zoneinfo-paths [ parse-zoneinfo-file ] map ;
  93
  94 MEMO: zoneinfo-array ( -- seq )
  95     zoneinfo-files concat ;
  96
  97 : raw-rule-map ( -- assoc )
  98     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
  99
 100 : raw-zone-map ( -- assoc )
 101     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 102
 103 : zoneinfo-zones ( -- seq )
 104     raw-zone-map keys
 105     [ "/" swap subseq? ] partition
 106     [ natural-sort ] bi@ append ;
 107
 108 GENERIC: zone-matches? ( string rule -- ? )
 109
 110 M: raw-rule zone-matches? name>> = ;
 111 M: raw-link zone-matches? from>> = ;
 112 M: raw-leap zone-matches? 2drop f ;
 113 M: raw-zone zone-matches? name>> = ;
 114
 115 : find-rules ( string -- rules )
 116     raw-rule-map
 117     [ [ to>> "max" = ] filter ] assoc-map at ;
 118
 119 ERROR: zone-not-found name ;
 120
 121 : find-zone ( string -- zone )
 122     raw-zone-map
 123     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 124
 125 : find-zone-rules ( string -- zone rules )
 126     find-zone dup rules/save>> find-rules ;
 127
 128 : zone-abbrevs ( -- assoc )
 129     zoneinfo-zones [
 130         find-zone-rules [ format>> ] dip
 131         [
 132             letters>> swap "%" split1 dup [ 1 tail ] when surround
 133         ] with V{ } map-as
 134     ] map-zip ;
 135
 136 : number>value ( n -- n' )
 137     {
 138         { "only" [ f ] }
 139         { "min" [ f ] }
 140         { "max" [ t ] }
 141         [ string>number ]
 142     } case ;
 143
 144 : on>value ( n -- n' )
 145     ! "3", "Thu>=8" always >=, "lastFri"
 146     {
 147         { [ dup 3 swap ?nth CHAR: > = ] [
 148             3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
 149         ] }
 150         { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
 151         [ string>number ]
 152     } cond ;
 153
 154 : raw-rule>triple ( raw-rule -- quot )
 155     {
 156         [ from>> string>number ]
 157         [ in>> month-abbreviation-index ]
 158         [ on>> on>value ]
 159     } cleave>array ;