basis/calendar/format/format.factor

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