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 io
   4 io.streams.string kernel macros math math.order math.parser
   5 math.parser.private present quotations sequences typed 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 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
  22
  23 : write-00 ( n -- ) pad-00 write ;
  24
  25 : write-0000 ( n -- ) pad-0000 write ;
  26
  27 : write-00000 ( n -- ) pad-00000 write ;
  28
  29 : hh ( time -- ) hour>> write-00 ;
  30
  31 : mm ( time -- ) minute>> write-00 ;
  32
  33 : ss ( time -- ) second>> >integer write-00 ;
  34
  35 : D ( time -- ) day>> number>string write ;
  36
  37 : DD ( time -- ) day>> write-00 ;
  38
  39 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
  40
  41 : MM ( time -- ) month>> write-00 ;
  42
  43 : MONTH ( time -- ) month>> month-abbreviation write ;
  44
  45 : YYYY ( time -- ) year>> write-0000 ;
  46
  47 : YYYYY ( time -- ) year>> write-00000 ;
  48
  49 GENERIC: day. ( obj -- )
  50
  51 M: integer day. ( n -- )
  52     number>string dup length 2 < [ bl ] when write ;
  53
  54 M: timestamp day. ( timestamp -- )
  55     day>> day. ;
  56
  57 GENERIC: month. ( obj -- )
  58
  59 M: array month. ( pair -- )
  60     first2
  61     [ month-name write bl number>string print ]
  62     [ 1 zeller-congruence ]
  63     [ (days-in-month) day-abbreviations2 " " join print ] 2tri
  64     over "   " <repetition> "" concat-as write
  65     [
  66         [ 1 + day. ] keep
  67         1 + + 7 mod zero? [ nl ] [ bl ] if
  68     ] with each-integer nl ;
  69
  70 M: timestamp month. ( timestamp -- )
  71     [ year>> ] [ month>> ] bi 2array month. ;
  72
  73 GENERIC: year. ( obj -- )
  74
  75 M: integer year. ( n -- )
  76     12 [ 1 + 2array month. nl ] with each-integer ;
  77
  78 M: timestamp year. ( timestamp -- )
  79     year>> year. ;
  80
  81 : timestamp>mdtm ( timestamp -- str )
  82     [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
  83
  84 : (timestamp>string) ( timestamp -- )
  85     { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
  86
  87 : timestamp>string ( timestamp -- str )
  88     [ (timestamp>string) ] with-string-writer ;
  89
  90 : write-hhmm ( duration -- )
  91     [ hh ] [ mm ] bi ;
  92
  93 : write-gmt-offset ( gmt-offset -- )
  94     dup instant <=> {
  95         { +eq+ [ drop "GMT" write ] }
  96         { +lt+ [ "-" write before write-hhmm ] }
  97         { +gt+ [ "+" write write-hhmm ] }
  98     } case ;
  99
 100 : write-gmt-offset-number ( gmt-offset -- )
 101     dup instant <=> {
 102         { +eq+ [ drop "+0000" write ] }
 103         { +lt+ [ "-" write before write-hhmm ] }
 104         { +gt+ [ "+" write write-hhmm ] }
 105     } case ;
 106
 107 : timestamp>rfc822 ( timestamp -- str )
 108     ! RFC822 timestamp format
 109     ! Example: Tue, 15 Nov 1994 08:12:31 +0200
 110     [
 111         [ (timestamp>string) bl ]
 112         [ gmt-offset>> write-gmt-offset ]
 113         bi
 114     ] with-string-writer ;
 115
 116 : timestamp>git-time ( timestamp -- str )
 117     [
 118         [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
 119         [ gmt-offset>> write-gmt-offset-number ] bi
 120     ] with-string-writer ;
 121
 122 : timestamp>http-string ( timestamp -- str )
 123     ! http timestamp format
 124     ! Example: Tue, 15 Nov 1994 08:12:31 GMT
 125     >gmt timestamp>rfc822 ;
 126
 127 : (timestamp>cookie-string) ( timestamp -- )
 128     >gmt
 129     { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
 130
 131 : timestamp>cookie-string ( timestamp -- str )
 132     [ (timestamp>cookie-string) ] with-string-writer ;
 133
 134 : (write-rfc3339-gmt-offset) ( duration -- )
 135     [ hh ":" write ] [ mm ] bi ;
 136
 137 : write-rfc3339-gmt-offset ( duration -- )
 138     dup instant <=> {
 139         { +eq+ [ drop "Z" write ] }
 140         { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
 141         { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
 142     } case ;
 143
 144 ! Should be enough for anyone, allows to not do a fancy
 145 ! algorithm to detect infinite decimals (e.g 1/3)
 146 : ss.SSSSSS ( timestamp -- )
 147     second>> >float "0" 9 6 "f" "C" format-float write ;
 148
 149 : (timestamp>rfc3339) ( timestamp -- )
 150     {
 151         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
 152         [ gmt-offset>> write-rfc3339-gmt-offset ]
 153     } formatted ;
 154
 155 : timestamp>rfc3339 ( timestamp -- str )
 156     [ (timestamp>rfc3339) ] with-string-writer ;
 157
 158 : (timestamp>ymd) ( timestamp -- )
 159     { YYYY "-" MM "-" DD } formatted ;
 160
 161 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
 162     [ (timestamp>ymd) ] with-string-writer ;
 163
 164 : (timestamp>hms) ( timestamp -- )
 165     { hh ":" mm ":" ss } formatted ;
 166
 167 TYPED: timestamp>hms ( timestamp: timestamp -- str )
 168     [ (timestamp>hms) ] with-string-writer ;
 169
 170 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
 171     [
 172         >gmt
 173         { (timestamp>ymd) " " (timestamp>hms) } formatted
 174     ] with-string-writer ;
 175
 176 : file-time-string ( timestamp -- string )
 177     [
 178         {
 179             MONTH " " DD " "
 180             [
 181                 dup now [ year>> ] same?
 182                 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
 183             ]
 184         } formatted
 185     ] with-string-writer ;
 186
 187 M: timestamp present timestamp>string ;
 188
 189 TYPED: duration>hm ( duration: duration -- string )
 190     [ duration>hours >integer 24 mod pad-00 ]
 191     [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
 192
 193 TYPED: duration>human-readable ( duration: duration -- string )
 194     [
 195         [
 196             duration>years >integer
 197             [
 198                 [ number>string write ]
 199                 [ 1 > " years, " " year, " ? write ] bi
 200             ] unless-zero
 201         ] [
 202             duration>days >integer 365 mod
 203             [
 204                 [ number>string write ]
 205                 [ 1 > " days, " " day, " ? write ] bi
 206             ] unless-zero
 207         ] [ duration>hm write ] tri
 208     ] with-string-writer ;