basis/calendar/format/format.factor

   1 USING: math math.order math.parser math.functions kernel sequences io\r
   2 accessors arrays io.streams.string splitting\r
   3 combinators accessors debugger\r
   4 calendar calendar.format.macros ;\r
   5 IN: calendar.format\r
   6 \r
   7 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
   8 \r
   9 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;\r
  10 \r
  11 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;\r
  12 \r
  13 : write-00 ( n -- ) pad-00 write ;\r
  14 \r
  15 : write-0000 ( n -- ) pad-0000 write ;\r
  16 \r
  17 : write-00000 ( n -- ) pad-00000 write ;\r
  18 \r
  19 : hh ( time -- ) hour>> write-00 ;\r
  20 \r
  21 : mm ( time -- ) minute>> write-00 ;\r
  22 \r
  23 : ss ( time -- ) second>> >integer write-00 ;\r
  24 \r
  25 : D ( time -- ) day>> number>string write ;\r
  26 \r
  27 : DD ( time -- ) day>> write-00 ;\r
  28 \r
  29 : DAY ( time -- ) day-of-week day-abbreviation3 write ;\r
  30 \r
  31 : MM ( time -- ) month>> write-00 ;\r
  32 \r
  33 : MONTH ( time -- ) month>> month-abbreviation write ;\r
  34 \r
  35 : YYYY ( time -- ) year>> write-0000 ;\r
  36 \r
  37 : YYYYY ( time -- ) year>> write-00000 ;\r
  38 \r
  39 : expect ( str -- )\r
  40     read1 swap member? [ "Parse error" throw ] unless ;\r
  41 \r
  42 : read-00 ( -- n ) 2 read string>number ;\r
  43 \r
  44 : read-000 ( -- n ) 3 read string>number ;\r
  45 \r
  46 : read-0000 ( -- n ) 4 read string>number ;\r
  47 \r
  48 GENERIC: day. ( obj -- )\r
  49 \r
  50 M: integer day. ( n -- )\r
  51     number>string dup length 2 < [ bl ] when write ;\r
  52 \r
  53 M: timestamp day. ( timestamp -- )\r
  54     day>> day. ;\r
  55 \r
  56 GENERIC: month. ( obj -- )\r
  57 \r
  58 M: array month. ( pair -- )\r
  59     first2\r
  60     [ month-name write bl number>string print ]\r
  61     [ 1 zeller-congruence ]\r
  62     [ (days-in-month) day-abbreviations2 " " join print ] 2tri\r
  63     over "   " <repetition> concat write\r
  64     [\r
  65         [ 1+ day. ] keep\r
  66         1+ + 7 mod zero? [ nl ] [ bl ] if\r
  67     ] with each nl ;\r
  68 \r
  69 M: timestamp month. ( timestamp -- )\r
  70     [ year>> ] [ month>> ] bi 2array month. ;\r
  71 \r
  72 GENERIC: year. ( obj -- )\r
  73 \r
  74 M: integer year. ( n -- )\r
  75     12 [ 1+ 2array month. nl ] with each ;\r
  76 \r
  77 M: timestamp year. ( timestamp -- )\r
  78     year>> year. ;\r
  79 \r
  80 : (timestamp>string) ( timestamp -- )\r
  81     { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;\r
  82 \r
  83 : timestamp>string ( timestamp -- str )\r
  84     [ (timestamp>string) ] with-string-writer ;\r
  85 \r
  86 : (write-gmt-offset) ( duration -- )\r
  87     [ hh ] [ mm ] bi ;\r
  88 \r
  89 : write-gmt-offset ( gmt-offset -- )\r
  90     dup instant <=> {\r
  91         { +eq+ [ drop "GMT" write ] }\r
  92         { +lt+ [ "-" write before (write-gmt-offset) ] }\r
  93         { +gt+ [ "+" write (write-gmt-offset) ] }\r
  94     } case ;\r
  95 \r
  96 : timestamp>rfc822 ( timestamp -- str )\r
  97     #! RFC822 timestamp format\r
  98     #! Example: Tue, 15 Nov 1994 08:12:31 +0200\r
  99     [\r
 100         [ (timestamp>string) " " write ]\r
 101         [ gmt-offset>> write-gmt-offset ]\r
 102         bi\r
 103     ] with-string-writer ;\r
 104 \r
 105 : timestamp>http-string ( timestamp -- str )\r
 106     #! http timestamp format\r
 107     #! Example: Tue, 15 Nov 1994 08:12:31 GMT\r
 108     >gmt timestamp>rfc822 ;\r
 109 \r
 110 : (timestamp>cookie-string) ( timestamp -- )\r
 111     >gmt\r
 112     { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;\r
 113 \r
 114 : timestamp>cookie-string ( timestamp -- str )\r
 115     [ (timestamp>cookie-string) ] with-string-writer ;\r
 116 \r
 117 : (write-rfc3339-gmt-offset) ( duration -- )\r
 118     [ hh ":" write ] [ mm ] bi ;\r
 119 \r
 120 : write-rfc3339-gmt-offset ( duration -- )\r
 121     dup instant <=> {\r
 122         { +eq+ [ drop "Z" write ] }\r
 123         { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }\r
 124         { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }\r
 125     } case ;\r
 126     \r
 127 : (timestamp>rfc3339) ( timestamp -- )\r
 128     {\r
 129         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss\r
 130         [ gmt-offset>> write-rfc3339-gmt-offset ]\r
 131     } formatted ;\r
 132 \r
 133 : timestamp>rfc3339 ( timestamp -- str )\r
 134     [ (timestamp>rfc3339) ] with-string-writer ;\r
 135 \r
 136 : signed-gmt-offset ( dt ch -- dt' )\r
 137     { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;\r
 138 \r
 139 : read-rfc3339-gmt-offset ( ch -- dt )\r
 140     dup CHAR: Z = [ drop instant ] [\r
 141         >r\r
 142         read-00 hours\r
 143         read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes\r
 144         time+\r
 145         r> signed-gmt-offset\r
 146     ] if ;\r
 147 \r
 148 : read-ymd ( -- y m d )\r
 149     read-0000 "-" expect read-00 "-" expect read-00 ;\r
 150 \r
 151 : read-hms ( -- h m s )\r
 152     read-00 ":" expect read-00 ":" expect read-00 ;\r
 153 \r
 154 : read-rfc3339-seconds ( s -- s' ch )\r
 155     "+-Z" read-until >r\r
 156     [ string>number ] [ length 10 swap ^ ] bi / + r> ;\r
 157 \r
 158 : (rfc3339>timestamp) ( -- timestamp )\r
 159     read-ymd\r
 160     "Tt" expect\r
 161     read-hms\r
 162     read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case\r
 163     read-rfc3339-gmt-offset\r
 164     <timestamp> ;\r
 165 \r
 166 : rfc3339>timestamp ( str -- timestamp )\r
 167     [ (rfc3339>timestamp) ] with-string-reader ;\r
 168 \r
 169 ERROR: invalid-timestamp-format ;\r
 170 \r
 171 : check-timestamp ( obj/f -- obj )\r
 172     [ invalid-timestamp-format ] unless* ;\r
 173 \r
 174 : read-token ( seps -- token )\r
 175     [ read-until ] keep member? check-timestamp drop ;\r
 176 \r
 177 : read-sp ( -- token ) " " read-token ;\r
 178 \r
 179 : checked-number ( str -- n )\r
 180     string>number check-timestamp ;\r
 181 \r
 182 : parse-rfc822-gmt-offset ( string -- dt )\r
 183     dup "GMT" = [ drop instant ] [\r
 184         unclip >r\r
 185         2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+\r
 186         r> signed-gmt-offset\r
 187     ] if ;\r
 188 \r
 189 : (rfc822>timestamp) ( -- timestamp )\r
 190     timestamp new\r
 191         "," read-token day-abbreviations3 member? check-timestamp drop\r
 192         read1 CHAR: \s assert=\r
 193         read-sp checked-number >>day\r
 194         read-sp month-abbreviations index 1+ check-timestamp >>month\r
 195         read-sp checked-number >>year\r
 196         ":" read-token checked-number >>hour\r
 197         ":" read-token checked-number >>minute\r
 198         " " read-token checked-number >>second\r
 199         readln parse-rfc822-gmt-offset >>gmt-offset ;\r
 200 \r
 201 : rfc822>timestamp ( str -- timestamp )\r
 202     [ (rfc822>timestamp) ] with-string-reader ;\r
 203 \r
 204 : check-day-name ( str -- )\r
 205     [ day-abbreviations3 member? ] [ day-names member? ] bi or\r
 206     check-timestamp drop ;\r
 207 \r
 208 : (cookie-string>timestamp-1) ( -- timestamp )\r
 209     timestamp new\r
 210         "," read-token check-day-name\r
 211         read1 CHAR: \s assert=\r
 212         "-" read-token checked-number >>day\r
 213         "-" read-token month-abbreviations index 1+ check-timestamp >>month\r
 214         read-sp checked-number >>year\r
 215         ":" read-token checked-number >>hour\r
 216         ":" read-token checked-number >>minute\r
 217         " " read-token checked-number >>second\r
 218         readln parse-rfc822-gmt-offset >>gmt-offset ;\r
 219 \r
 220 : cookie-string>timestamp-1 ( str -- timestamp )\r
 221     [ (cookie-string>timestamp-1) ] with-string-reader ;\r
 222 \r
 223 : (cookie-string>timestamp-2) ( -- timestamp )\r
 224     timestamp new\r
 225         read-sp check-day-name\r
 226         read-sp month-abbreviations index 1+ check-timestamp >>month\r
 227         read-sp checked-number >>day\r
 228         ":" read-token checked-number >>hour\r
 229         ":" read-token checked-number >>minute\r
 230         " " read-token checked-number >>second\r
 231         read-sp checked-number >>year\r
 232         readln parse-rfc822-gmt-offset >>gmt-offset ;\r
 233 \r
 234 : cookie-string>timestamp-2 ( str -- timestamp )\r
 235     [ (cookie-string>timestamp-2) ] with-string-reader ;\r
 236 \r
 237 : cookie-string>timestamp ( str -- timestamp )\r
 238     {\r
 239         [ cookie-string>timestamp-1 ]\r
 240         [ cookie-string>timestamp-2 ]\r
 241         [ rfc822>timestamp ]\r
 242     } attempt-all-quots ;\r
 243 \r
 244 : (ymdhms>timestamp) ( -- timestamp )\r
 245     read-ymd " " expect read-hms instant <timestamp> ;\r
 246 \r
 247 : ymdhms>timestamp ( str -- timestamp )\r
 248     [ (ymdhms>timestamp) ] with-string-reader ;\r
 249 \r
 250 : (hms>timestamp) ( -- timestamp )\r
 251     0 0 0 read-hms instant <timestamp> ;\r
 252 \r
 253 : hms>timestamp ( str -- timestamp )\r
 254     [ (hms>timestamp) ] with-string-reader ;\r
 255 \r
 256 : (ymd>timestamp) ( -- timestamp )\r
 257     read-ymd 0 0 0 instant <timestamp> ;\r
 258 \r
 259 : ymd>timestamp ( str -- timestamp )\r
 260     [ (ymd>timestamp) ] with-string-reader ;\r
 261 \r
 262 : (timestamp>ymd) ( timestamp -- )\r
 263     { YYYY "-" MM "-" DD } formatted ;\r
 264 \r
 265 : timestamp>ymd ( timestamp -- str )\r
 266     [ (timestamp>ymd) ] with-string-writer ;\r
 267 \r
 268 : (timestamp>hms) ( timestamp -- )\r
 269     { hh ":" mm ":" ss } formatted ;\r
 270 \r
 271 : timestamp>hms ( timestamp -- str )\r
 272     [ (timestamp>hms) ] with-string-writer ;\r
 273 \r
 274 : timestamp>ymdhms ( timestamp -- str )\r
 275     [\r
 276         >gmt\r
 277         { (timestamp>ymd) " " (timestamp>hms) } formatted\r
 278     ] with-string-writer ;\r
 279 \r
 280 : file-time-string ( timestamp -- string )\r
 281     [\r
 282         {\r
 283             MONTH " " DD " "\r
 284             [\r
 285                 dup now [ year>> ] bi@ =\r
 286                 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if\r
 287             ]\r
 288         } formatted\r
 289     ] with-string-writer ;\r