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