basis/calendar/format/format.factor

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