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