basis/calendar/format/format.factor

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