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