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 math.parser.private ranges present
6 quotations sequences splitting strings words ;
9 MACRO: formatted ( spec -- quot )
12 { [ dup word? ] [ 1quotation ] }
13 { [ dup quotation? ] [ ] }
14 [ [ nip write ] curry ]
16 ] map [ cleave ] curry ;
18 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
20 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
22 : write-00 ( n -- ) pad-00 write ;
24 : write-0000 ( n -- ) pad-0000 write ;
26 : hh ( timestamp -- ) hour>> write-00 ;
28 : mm ( timestamp -- ) minute>> write-00 ;
30 : ss ( timestamp -- ) second>> >integer write-00 ;
32 ! Should be enough for anyone, allows to not do a fancy
33 ! algorithm to detect infinite decimals (e.g 1/3)
34 : ss.SSSSSS ( timestamp -- )
35 second>> >float "0" 9 6 "f" "C" format-float write ;
37 : hhmm ( timestamp -- ) [ hh ] [ mm ] bi ;
39 : hh:mm ( timestamp -- ) { hh ":" mm } formatted ;
41 : hh:mm:ss ( timestamp -- ) { hh ":" mm ":" ss } formatted ;
43 : hh:mm:ss.SSSSSS ( timestamp -- ) { hh ":" mm ":" ss.SSSSSS } formatted ;
45 : D ( timestamp -- ) day>> number>string write ;
47 : DD ( timestamp -- ) day>> write-00 ;
49 : DAY ( timestamp -- ) day-of-week day-abbreviation3 write ;
51 : MM ( timestamp -- ) month>> write-00 ;
53 : MONTH ( timestamp -- ) month>> month-abbreviation write ;
55 : YYYY ( timestamp -- ) year>> write-0000 ;
57 : YYYY-MM-DD ( timestamp -- ) { YYYY "-" MM "-" DD } formatted ;
59 GENERIC: day. ( obj -- )
62 number>string dup length 2 < [ bl ] when write ;
69 : center. ( str n -- )
70 over length [-] 2/ CHAR: \s <string> write print ;
72 : month-header. ( year month -- )
73 [ number>string ] [ month-name ] bi* swap " " glue 20 center. ;
76 day-abbreviations2 join-words print ;
78 : days. ( year month -- )
79 [ 1 (day-of-week) dup [ " " write ] times ]
80 [ (days-in-month) ] 2bi [1..b] [
81 [ day. ] [ + 7 mod zero? [ nl ] [ bl ] if ] bi
86 : month. ( timestamp -- )
87 [ year>> ] [ month>> ] bi
88 [ month-header. ] [ days-header. days. ] 2bi ;
90 GENERIC: year. ( obj -- )
93 dup number>string 64 center. nl 12 [1..b] [
95 [ month-name 20 center. ]
96 [ days-header. days. nl nl ] bi
97 ] with-string-writer split-lines
99 [ first3 [ "%-20s %-20s %-20s\n" printf ] 3each ] each ;
101 M: timestamp year. year>> year. ;
103 : timestamp>mdtm ( timestamp -- str )
104 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
106 : timestamp>ymd ( timestamp -- str )
107 [ YYYY-MM-DD ] with-string-writer ;
109 : timestamp>hms ( timestamp -- str )
110 [ hh:mm:ss ] with-string-writer ;
112 : timestamp>ymdhms ( timestamp -- str )
113 [ >gmt { YYYY-MM-DD " " hh:mm:ss } formatted ] with-string-writer ;
115 : write-gmt-offset-hhmm ( gmt-offset -- )
116 [ hour>> dup 0 < "-" "+" ? write abs write-00 ] [ mm ] bi ;
118 : write-gmt-offset-hh:mm ( gmt-offset -- )
119 [ hour>> dup 0 < "-" "+" ? write abs write-00 ":" write ] [ mm ] bi ;
121 : write-gmt-offset ( gmt-offset -- )
122 dup instant = [ drop "GMT" write ] [ write-gmt-offset-hhmm ] if ;
124 : write-gmt-offset-z ( gmt-offset -- )
125 dup instant = [ drop "Z" write ] [ write-gmt-offset-hh:mm ] if ;
127 : write-rfc1036 ( timestamp -- )
129 DAY ", " DD "-" MONTH "-" YYYY " " hh:mm:ss " "
130 [ gmt-offset>> write-gmt-offset ]
133 : timestamp>rfc1036 ( timestamp -- str )
134 [ write-rfc1036 ] with-string-writer ;
136 ! RFC850 obsoleted by RFC1036
137 ALIAS: write-rfc850 write-rfc1036
138 ALIAS: timestamp>rfc850 timestamp>rfc1036
140 : write-rfc2822 ( timestamp -- )
142 DAY ", " D " " MONTH " " YYYY " " hh:mm:ss " "
143 [ gmt-offset>> write-gmt-offset ]
146 : timestamp>rfc2822 ( timestamp -- str )
147 [ write-rfc2822 ] with-string-writer ;
149 ! RFC822 obsoleted by RFC2822
150 ALIAS: write-rfc822 write-rfc2822
151 ALIAS: timestamp>rfc822 timestamp>rfc2822
153 : write-rfc3339 ( timestamp -- )
155 YYYY-MM-DD "T" hh:mm:ss.SSSSSS
156 [ gmt-offset>> write-gmt-offset-z ]
159 : timestamp>rfc3339 ( timestamp -- str )
160 [ write-rfc3339 ] with-string-writer ;
162 : write-iso8601 ( timestamp -- )
164 YYYY-MM-DD "T" hh:mm:ss.SSSSSS
165 [ gmt-offset>> write-gmt-offset-hh:mm ]
168 : timestamp>iso8601 ( timestamp -- str )
169 [ write-iso8601 ] with-string-writer ;
171 : write-ctime ( timestamp -- )
173 DAY " " MONTH " " DD " " hh:mm:ss " " YYYY
176 : timestamp>ctime-string ( timestamp -- str )
177 [ write-ctime ] with-string-writer ;
179 : timestamp>git-string ( timestamp -- str )
182 DAY " " MONTH " " D " " hh:mm:ss " " YYYY " "
183 [ gmt-offset>> write-gmt-offset-hhmm ]
185 ] with-string-writer ;
187 : timestamp>http-string ( timestamp -- str )
188 >gmt timestamp>rfc2822 ;
190 : timestamp>cookie-string ( timestamp -- str )
191 >gmt timestamp>rfc1036 ;
193 : write-timestamp ( timestamp -- )
194 { DAY ", " D " " MONTH " " YYYY " " hh:mm:ss } formatted ;
196 : timestamp>string ( timestamp -- str )
197 [ write-timestamp ] with-string-writer ;
199 M: timestamp present timestamp>string ;
201 : duration>hm ( duration -- str )
202 [ duration>hours >integer 24 mod pad-00 ]
203 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
205 : duration>hms ( duration -- str )
207 [ duration>seconds >integer 60 mod pad-00 ] bi ":" glue ;
209 : duration>human-readable ( duration -- string )
212 duration>years >integer
214 [ number>string write ]
215 [ 1 > " years, " " year, " ? write ] bi
218 duration>days >integer 365 mod
220 [ number>string write ]
221 [ 1 > " days, " " day, " ? write ] bi
223 ] [ duration>hms write ] tri
224 ] with-string-writer ;
226 GENERIC: elapsed-time ( seconds -- string )
228 M: integer elapsed-time
229 dup 0 < [ "negative seconds" throw ] when [
238 [ first [ /mod ] [ dup ] if* ] [ second ] bi swap
239 dup 0 > [ number>string prepend , ] [ 2drop ] if
241 ] { } make [ "0s" ] [ reverse join-words ] if-empty ;
244 >integer elapsed-time ;
246 M: duration elapsed-time
247 duration>seconds elapsed-time ;
249 M: timestamp elapsed-time
252 ! XXX: Anything up to 2 hours is "about an hour"
253 : relative-time-offset ( seconds -- string )
255 { [ dup 1 < ] [ drop "just now" ] }
256 { [ dup 60 < ] [ drop "less than a minute" ] }
257 { [ dup 120 < ] [ drop "about a minute" ] }
258 { [ dup 2700 < ] [ 60 /i "%d minutes" sprintf ] }
259 { [ dup 7200 < ] [ drop "about an hour" ] }
260 { [ dup 86400 < ] [ 3600 /i "%d hours" sprintf ] }
261 { [ dup 172800 < ] [ drop "1 day" ] }
262 [ 86400 /i "%d days" sprintf ]
265 GENERIC: relative-time ( seconds -- string )
267 M: real relative-time
268 [ relative-time-offset ] [
272 0 < "hence" "ago" ? " " glue
276 M: duration relative-time
277 duration>seconds relative-time ;
279 M: timestamp relative-time