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.english combinators
   4 formatting io io.streams.string kernel make math math.parser
   5 math.parser.private present quotations sequences words ;
   6 IN: calendar.format
   7
   8 MACRO: formatted ( spec -- quot )
   9     [
  10         {
  11             { [ dup word? ] [ 1quotation ] }
  12             { [ dup quotation? ] [ ] }
  13             [ [ nip write ] curry [ ] like ]
  14         } cond
  15     ] map [ cleave ] curry ;
  16
  17 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
  18
  19 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
  20
  21 : write-00 ( n -- ) pad-00 write ;
  22
  23 : write-0000 ( n -- ) pad-0000 write ;
  24
  25 : hh ( timestamp -- ) hour>> write-00 ;
  26
  27 : mm ( timestamp -- ) minute>> write-00 ;
  28
  29 : ss ( timestamp -- ) second>> >integer write-00 ;
  30
  31 ! Should be enough for anyone, allows to not do a fancy
  32 ! algorithm to detect infinite decimals (e.g 1/3)
  33 : ss.SSSSSS ( timestamp -- )
  34     second>> >float "0" 9 6 "f" "C" format-float write ;
  35
  36 : hhmm ( timestamp -- ) [ hh ] [ mm ] bi ;
  37
  38 : hh:mm ( timestamp -- ) { hh ":" mm } formatted ;
  39
  40 : hh:mm:ss ( timestamp -- ) { hh ":" mm ":" ss } formatted ;
  41
  42 : hh:mm:ss.SSSSSS ( timestamp -- ) { hh ":" mm ":" ss.SSSSSS } formatted ;
  43
  44 : D ( timestamp -- ) day>> number>string write ;
  45
  46 : DD ( timestamp -- ) day>> write-00 ;
  47
  48 : DAY ( timestamp -- ) day-of-week day-abbreviation3 write ;
  49
  50 : MM ( timestamp -- ) month>> write-00 ;
  51
  52 : MONTH ( timestamp -- ) month>> month-abbreviation write ;
  53
  54 : YYYY ( timestamp -- ) year>> write-0000 ;
  55
  56 : YYYY-MM-DD ( timestamp -- ) { YYYY "-" MM "-" DD } formatted ;
  57
  58 GENERIC: day. ( obj -- )
  59
  60 M: integer day.
  61     number>string dup length 2 < [ bl ] when write ;
  62
  63 M: timestamp day.
  64     day>> day. ;
  65
  66 GENERIC: month. ( obj -- )
  67
  68 M: array month.
  69     first2
  70     [ month-name write bl number>string print ]
  71     [ 1 zeller-congruence ]
  72     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
  73     over "   " <repetition> "" concat-as write
  74     [
  75         [ 1 + day. ] keep
  76         1 + + 7 mod zero? [ nl ] [ bl ] if
  77     ] with each-integer nl ;
  78
  79 M: timestamp month.
  80     [ year>> ] [ month>> ] bi 2array month. ;
  81
  82 GENERIC: year. ( obj -- )
  83
  84 M: integer year.
  85     12 [ 1 + 2array month. nl ] with each-integer ;
  86
  87 M: timestamp year. year>> year. ;
  88
  89 : timestamp>mdtm ( timestamp -- str )
  90     [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
  91
  92 : timestamp>ymd ( timestamp -- str )
  93     [ YYYY-MM-DD ] with-string-writer ;
  94
  95 : timestamp>hms ( timestamp -- str )
  96     [ hh:mm:ss ] with-string-writer ;
  97
  98 : timestamp>ymdhms ( timestamp -- str )
  99     [ >gmt YYYY-MM-DD " " hh:mm:ss ] with-string-writer ;
 100
 101 : write-gmt-offset-hhmm ( gmt-offset -- )
 102     [ hour>> dup 0 < "-" "+" ? write abs write-00 ] [ mm ] bi ;
 103
 104 : write-gmt-offset-hh:mm ( gmt-offset -- )
 105     [ hour>> dup 0 < "-" "+" ? write abs write-00 ":" write ] [ mm ] bi ;
 106
 107 : write-gmt-offset ( gmt-offset -- )
 108     dup instant = [ drop "GMT" write ] [ write-gmt-offset-hhmm ] if ;
 109
 110 : write-gmt-offset-z ( gmt-offset -- )
 111     dup instant = [ drop "Z" write ] [ write-gmt-offset-hh:mm ] if ;
 112
 113 : write-rfc1036 ( timestamp -- )
 114     {
 115         DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " "
 116         [ gmt-offset>> write-gmt-offset ]
 117     } formatted ;
 118
 119 : timestamp>rfc1036 ( timestamp -- str )
 120     [ write-rfc1036 ] with-string-writer ;
 121
 122 ! RFC850 obsoleted by RFC1036
 123 ALIAS: write-rfc850 write-rfc1036
 124 ALIAS: timestamp>rfc850 timestamp>rfc1036
 125
 126 : write-rfc2822 ( timestamp -- )
 127     {
 128         DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss " "
 129         [ gmt-offset>> write-gmt-offset ]
 130     } formatted ;
 131
 132 : timestamp>rfc2822 ( timestamp -- str )
 133     [ write-rfc2822 ] with-string-writer ;
 134
 135 ! RFC822 obsoleted by RFC2822
 136 ALIAS: write-rfc822 write-rfc2822
 137 ALIAS: timestamp>rfc822 timestamp>rfc2822
 138
 139 : write-rfc3339 ( timestamp -- )
 140     {
 141         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
 142         [ gmt-offset>> write-gmt-offset-z ]
 143     } formatted ;
 144
 145 : timestamp>rfc3339 ( timestamp -- str )
 146     [ write-rfc3339 ] with-string-writer ;
 147
 148 : write-iso8601 ( timestamp -- )
 149     {
 150         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
 151         [ gmt-offset>> write-gmt-offset-hh:mm ]
 152     } formatted ;
 153
 154 : timestamp>iso8601 ( timestamp -- str )
 155     [ write-iso8601 ] with-string-writer ;
 156
 157 : write-ctime ( timestamp -- )
 158     {
 159         DAY " " MONTH " " DD " " hh ":" mm ":" ss " " YYYY
 160     } formatted ;
 161
 162 : timestamp>ctime-string ( timestamp -- str )
 163     [ write-ctime ] with-string-writer ;
 164
 165 : timestamp>git-string ( timestamp -- str )
 166     [
 167         {
 168             DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " "
 169             [ gmt-offset>> write-gmt-offset-hhmm ]
 170         } formatted
 171     ] with-string-writer ;
 172
 173 : timestamp>http-string ( timestamp -- str )
 174     >gmt timestamp>rfc2822 ;
 175
 176 : timestamp>cookie-string ( timestamp -- str )
 177     >gmt timestamp>rfc1036 ;
 178
 179 : write-timestamp ( timestamp -- )
 180     { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
 181
 182 : timestamp>string ( timestamp -- str )
 183     [ write-timestamp ] with-string-writer ;
 184
 185 M: timestamp present timestamp>string ;
 186
 187 : duration>hm ( duration -- str )
 188     [ duration>hours >integer 24 mod pad-00 ]
 189     [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
 190
 191 : duration>hms ( duration -- str )
 192     [ duration>hm ] [ second>> >integer 60 mod pad-00 ] bi ":" glue ;
 193
 194 : duration>human-readable ( duration -- string )
 195     [
 196         [
 197             duration>years >integer
 198             [
 199                 [ number>string write ]
 200                 [ 1 > " years, " " year, " ? write ] bi
 201             ] unless-zero
 202         ] [
 203             duration>days >integer 365 mod
 204             [
 205                 [ number>string write ]
 206                 [ 1 > " days, " " day, " ? write ] bi
 207             ] unless-zero
 208         ] [ duration>hms write ] tri
 209     ] with-string-writer ;
 210
 211 GENERIC: elapsed-time ( seconds -- string )
 212
 213 M: integer elapsed-time
 214     dup 0 < [ "negative seconds" throw ] when [
 215         {
 216             { 60 "s" }
 217             { 60 "m" }
 218             { 24 "h" }
 219             {  7 "d" }
 220             { 52 "w" }
 221             {  f "y" }
 222         } [
 223             [ first [ /mod ] [ dup ] if* ] [ second ] bi swap
 224             dup 0 > [ number>string prepend , ] [ 2drop ] if
 225         ] each drop
 226     ] { } make [ "0s" ] [ reverse " " join ] if-empty ;
 227
 228 M: real elapsed-time
 229     >integer elapsed-time ;
 230
 231 M: duration elapsed-time
 232     duration>seconds elapsed-time ;
 233
 234 M: timestamp elapsed-time
 235     now swap time- elapsed-time ;
 236
 237 ! XXX: Anything up to 2 hours is "about an hour"
 238 : relative-time-offset ( seconds -- string )
 239     abs {
 240         { [ dup 1 < ] [ drop "just now" ] }
 241         { [ dup 60 < ] [ drop "less than a minute" ] }
 242         { [ dup 120 < ] [ drop "about a minute" ] }
 243         { [ dup 2700 < ] [ 60 /i "%d minutes" sprintf ] }
 244         { [ dup 7200 < ] [ drop "about an hour" ] }
 245         { [ dup 86400 < ] [ 3600 /i "%d hours" sprintf ] }
 246         { [ dup 172800 < ] [ drop "1 day" ] }
 247         [ 86400 /i "%d days" sprintf ]
 248     } cond ;
 249
 250 GENERIC: relative-time ( seconds -- string )
 251
 252 M: real relative-time
 253     [ relative-time-offset ] [
 254         dup abs 1 < [
 255             drop
 256         ] [
 257             0 < "hence" "ago" ? " " glue
 258         ] if
 259     ] bi ;
 260
 261 M: duration relative-time
 262     duration>seconds relative-time ;
 263
 264 M: timestamp relative-time
 265     now swap time- relative-time ;