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.
  83     year>> year. ;
  84
  85 : timestamp>mdtm ( timestamp -- str )
  86     [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
  87
  88 : (timestamp>string) ( timestamp -- )
  89     { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
  90
  91 : timestamp>string ( timestamp -- str )
  92     [ (timestamp>string) ] with-string-writer ;
  93
  94 : write-hhmm ( duration -- )
  95     [ hh ] [ mm ] bi ;
  96
  97 : write-gmt-offset ( gmt-offset -- )
  98     dup instant <=> {
  99         { +eq+ [ drop "GMT" write ] }
 100         { +lt+ [ "-" write before write-hhmm ] }
 101         { +gt+ [ "+" write write-hhmm ] }
 102     } case ;
 103
 104 : write-gmt-offset-number ( gmt-offset -- )
 105     dup instant <=> {
 106         { +eq+ [ drop "+0000" write ] }
 107         { +lt+ [ "-" write before write-hhmm ] }
 108         { +gt+ [ "+" write write-hhmm ] }
 109     } case ;
 110
 111 : timestamp>rfc822 ( timestamp -- str )
 112     ! RFC822 timestamp format
 113     ! Example: Tue, 15 Nov 1994 08:12:31 +0200
 114     [
 115         [ (timestamp>string) bl ]
 116         [ gmt-offset>> write-gmt-offset ]
 117         bi
 118     ] with-string-writer ;
 119
 120 : timestamp>git-time ( timestamp -- str )
 121     [
 122         [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
 123         [ gmt-offset>> write-gmt-offset-number ] bi
 124     ] with-string-writer ;
 125
 126 : timestamp>http-string ( timestamp -- str )
 127     ! http timestamp format
 128     ! Example: Tue, 15 Nov 1994 08:12:31 GMT
 129     >gmt timestamp>rfc822 ;
 130
 131 : (timestamp>cookie-string) ( timestamp -- )
 132     >gmt
 133     { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
 134
 135 : timestamp>cookie-string ( timestamp -- str )
 136     [ (timestamp>cookie-string) ] with-string-writer ;
 137
 138 : (write-rfc3339-gmt-offset) ( duration -- )
 139     [ hh ":" write ] [ mm ] bi ;
 140
 141 : write-rfc3339-gmt-offset ( duration -- )
 142     dup instant <=> {
 143         { +eq+ [ drop "Z" write ] }
 144         { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
 145         { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
 146     } case ;
 147
 148 ! Should be enough for anyone, allows to not do a fancy
 149 ! algorithm to detect infinite decimals (e.g 1/3)
 150 : ss.SSSSSS ( timestamp -- )
 151     second>> >float "0" 9 6 "f" "C" format-float write ;
 152
 153 : (timestamp>rfc3339) ( timestamp -- )
 154     {
 155         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
 156         [ gmt-offset>> write-rfc3339-gmt-offset ]
 157     } formatted ;
 158
 159 : timestamp>rfc3339 ( timestamp -- str )
 160     [ (timestamp>rfc3339) ] with-string-writer ;
 161
 162 : (write-rfc2822-gmt-offset) ( duration -- )
 163     [ hh ":" write ] [ mm ] bi ;
 164
 165 : write-rfc2822-gmt-offset ( duration -- )
 166     dup instant <=> {
 167         { +lt+ [ "-" write before (write-rfc2822-gmt-offset) ] }
 168         { +gt+ [ "+" write (write-rfc2822-gmt-offset) ] }
 169         { +eq+ [ "+" write (write-rfc2822-gmt-offset) ] }
 170     } case ;
 171
 172 : (timestamp>rfc2822) ( timestamp -- )
 173     {
 174         DAY ", " DD " " MONTH " " YYYY " " hh ":" mm ":" ss " "
 175         [ gmt-offset>> write-rfc2822-gmt-offset ]
 176     } formatted ;
 177
 178 : timestamp>rfc2822 ( timestamp -- str )
 179     [ (timestamp>rfc2822) ] with-string-writer ;
 180
 181 : (timestamp>ymd) ( timestamp -- )
 182     { YYYY "-" MM "-" DD } formatted ;
 183
 184 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
 185     [ (timestamp>ymd) ] with-string-writer ;
 186
 187 : (timestamp>hms) ( timestamp -- )
 188     { hh ":" mm ":" ss } formatted ;
 189
 190 TYPED: timestamp>hms ( timestamp: timestamp -- str )
 191     [ (timestamp>hms) ] with-string-writer ;
 192
 193 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
 194     [
 195         >gmt
 196         { (timestamp>ymd) " " (timestamp>hms) } formatted
 197     ] with-string-writer ;
 198
 199 : file-time-string ( timestamp -- string )
 200     [
 201         {
 202             MONTH " " DD " "
 203             [
 204                 dup now [ year>> ] same?
 205                 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
 206             ]
 207         } formatted
 208     ] with-string-writer ;
 209
 210 M: timestamp present timestamp>string ;
 211
 212 ! Duration formatting
 213 TYPED: duration>hm ( duration: duration -- str )
 214     [ duration>hours >integer 24 mod pad-00 ]
 215     [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
 216
 217 TYPED: duration>hms ( duration: duration -- str )
 218     [ duration>hm ] [ second>> >integer 60 mod pad-00 ] bi ":" glue ;
 219
 220 TYPED: duration>human-readable ( duration: duration -- string )
 221     [
 222         [
 223             duration>years >integer
 224             [
 225                 [ number>string write ]
 226                 [ 1 > " years, " " year, " ? write ] bi
 227             ] unless-zero
 228         ] [
 229             duration>days >integer 365 mod
 230             [
 231                 [ number>string write ]
 232                 [ 1 > " days, " " day, " ? write ] bi
 233             ] unless-zero
 234         ] [ duration>hms write ] tri
 235     ] with-string-writer ;