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
9 MACRO: formatted ( spec -- quot )
12 { [ dup word? ] [ 1quotation ] }
13 { [ dup quotation? ] [ ] }
14 [ [ nip write ] curry [ ] like ]
16 ] map [ cleave ] curry ;
18 : formatted>string ( spec -- string )
19 '[ _ formatted ] with-string-writer ; inline
21 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
23 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
25 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
27 : write-00 ( n -- ) pad-00 write ;
29 : write-0000 ( n -- ) pad-0000 write ;
31 : write-00000 ( n -- ) pad-00000 write ;
33 : hh ( time -- ) hour>> write-00 ;
35 : mm ( time -- ) minute>> write-00 ;
37 : ss ( time -- ) second>> >integer write-00 ;
39 : D ( time -- ) day>> number>string write ;
41 : DD ( time -- ) day>> write-00 ;
43 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
45 : MM ( time -- ) month>> write-00 ;
47 : MONTH ( time -- ) month>> month-abbreviation write ;
49 : YYYY ( time -- ) year>> write-0000 ;
51 : YYYYY ( time -- ) year>> write-00000 ;
53 GENERIC: day. ( obj -- )
55 M: integer day. ( n -- )
56 number>string dup length 2 < [ bl ] when write ;
58 M: timestamp day. ( timestamp -- )
61 GENERIC: month. ( obj -- )
63 M: array month. ( pair -- )
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
71 1 + + 7 mod zero? [ nl ] [ bl ] if
72 ] with each-integer nl ;
74 M: timestamp month. ( timestamp -- )
75 [ year>> ] [ month>> ] bi 2array month. ;
77 GENERIC: year. ( obj -- )
79 M: integer year. ( n -- )
80 12 [ 1 + 2array month. nl ] with each-integer ;
82 M: timestamp year. ( timestamp -- )
85 : timestamp>mdtm ( timestamp -- str )
86 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
88 : (timestamp>string) ( timestamp -- )
89 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
91 : timestamp>string ( timestamp -- str )
92 [ (timestamp>string) ] with-string-writer ;
94 : write-hhmm ( duration -- )
97 : write-gmt-offset ( gmt-offset -- )
99 { +eq+ [ drop "GMT" write ] }
100 { +lt+ [ "-" write before write-hhmm ] }
101 { +gt+ [ "+" write write-hhmm ] }
104 : write-gmt-offset-number ( gmt-offset -- )
106 { +eq+ [ drop "+0000" write ] }
107 { +lt+ [ "-" write before write-hhmm ] }
108 { +gt+ [ "+" write write-hhmm ] }
111 : timestamp>rfc822 ( timestamp -- str )
112 ! RFC822 timestamp format
113 ! Example: Tue, 15 Nov 1994 08:12:31 +0200
115 [ (timestamp>string) bl ]
116 [ gmt-offset>> write-gmt-offset ]
118 ] with-string-writer ;
120 : timestamp>git-time ( timestamp -- str )
122 [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
123 [ gmt-offset>> write-gmt-offset-number ] bi
124 ] with-string-writer ;
126 : timestamp>http-string ( timestamp -- str )
127 ! http timestamp format
128 ! Example: Tue, 15 Nov 1994 08:12:31 GMT
129 >gmt timestamp>rfc822 ;
131 : (timestamp>cookie-string) ( timestamp -- )
133 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
135 : timestamp>cookie-string ( timestamp -- str )
136 [ (timestamp>cookie-string) ] with-string-writer ;
138 : (write-rfc3339-gmt-offset) ( duration -- )
139 [ hh ":" write ] [ mm ] bi ;
141 : write-rfc3339-gmt-offset ( duration -- )
143 { +eq+ [ drop "Z" write ] }
144 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
145 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
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 ;
153 : (timestamp>rfc3339) ( timestamp -- )
155 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
156 [ gmt-offset>> write-rfc3339-gmt-offset ]
159 : timestamp>rfc3339 ( timestamp -- str )
160 [ (timestamp>rfc3339) ] with-string-writer ;
162 : (timestamp>ymd) ( timestamp -- )
163 { YYYY "-" MM "-" DD } formatted ;
165 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
166 [ (timestamp>ymd) ] with-string-writer ;
168 : (timestamp>hms) ( timestamp -- )
169 { hh ":" mm ":" ss } formatted ;
171 TYPED: timestamp>hms ( timestamp: timestamp -- str )
172 [ (timestamp>hms) ] with-string-writer ;
174 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
177 { (timestamp>ymd) " " (timestamp>hms) } formatted
178 ] with-string-writer ;
180 : file-time-string ( timestamp -- string )
185 dup now [ year>> ] same?
186 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
189 ] with-string-writer ;
191 M: timestamp present timestamp>string ;
193 ! Duration formatting
194 TYPED: duration>hm ( duration: duration -- str )
195 [ duration>hours >integer 24 mod pad-00 ]
196 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
198 TYPED: duration>hms ( duration: duration -- str )
199 [ duration>hm ] [ second>> >integer 60 mod pad-00 ] bi ":" glue ;
201 TYPED: duration>human-readable ( duration: duration -- string )
204 duration>years >integer
206 [ number>string write ]
207 [ 1 > " years, " " year, " ? write ] bi
210 duration>days >integer 365 mod
212 [ number>string write ]
213 [ 1 > " days, " " day, " ? write ] bi
215 ] [ duration>hms write ] tri
216 ] with-string-writer ;