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 ;
8 MACRO: formatted ( spec -- quot )
11 { [ dup word? ] [ 1quotation ] }
12 { [ dup quotation? ] [ ] }
13 [ [ nip write ] curry [ ] like ]
15 ] map [ cleave ] curry ;
17 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
19 : pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
21 : pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
23 : write-00 ( n -- ) pad-00 write ;
25 : write-0000 ( n -- ) pad-0000 write ;
27 : write-00000 ( n -- ) pad-00000 write ;
29 : hh ( time -- ) hour>> write-00 ;
31 : mm ( time -- ) minute>> write-00 ;
33 : ss ( time -- ) second>> >integer write-00 ;
35 : D ( time -- ) day>> number>string write ;
37 : DD ( time -- ) day>> write-00 ;
39 : DAY ( time -- ) day-of-week day-abbreviation3 write ;
41 : MM ( time -- ) month>> write-00 ;
43 : MONTH ( time -- ) month>> month-abbreviation write ;
45 : YYYY ( time -- ) year>> write-0000 ;
47 : YYYYY ( time -- ) year>> write-00000 ;
49 GENERIC: day. ( obj -- )
51 M: integer day. ( n -- )
52 number>string dup length 2 < [ bl ] when write ;
54 M: timestamp day. ( timestamp -- )
57 GENERIC: month. ( obj -- )
59 M: array month. ( pair -- )
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
67 1 + + 7 mod zero? [ nl ] [ bl ] if
68 ] with each-integer nl ;
70 M: timestamp month. ( timestamp -- )
71 [ year>> ] [ month>> ] bi 2array month. ;
73 GENERIC: year. ( obj -- )
75 M: integer year. ( n -- )
76 12 [ 1 + 2array month. nl ] with each-integer ;
78 M: timestamp year. ( timestamp -- )
81 : timestamp>mdtm ( timestamp -- str )
82 [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
84 : (timestamp>string) ( timestamp -- )
85 { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
87 : timestamp>string ( timestamp -- str )
88 [ (timestamp>string) ] with-string-writer ;
90 : write-hhmm ( duration -- )
93 : write-gmt-offset ( gmt-offset -- )
95 { +eq+ [ drop "GMT" write ] }
96 { +lt+ [ "-" write before write-hhmm ] }
97 { +gt+ [ "+" write write-hhmm ] }
100 : write-gmt-offset-number ( gmt-offset -- )
102 { +eq+ [ drop "+0000" write ] }
103 { +lt+ [ "-" write before write-hhmm ] }
104 { +gt+ [ "+" write write-hhmm ] }
107 : timestamp>rfc822 ( timestamp -- str )
108 ! RFC822 timestamp format
109 ! Example: Tue, 15 Nov 1994 08:12:31 +0200
111 [ (timestamp>string) bl ]
112 [ gmt-offset>> write-gmt-offset ]
114 ] with-string-writer ;
116 : timestamp>git-time ( timestamp -- str )
118 [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
119 [ gmt-offset>> write-gmt-offset-number ] bi
120 ] with-string-writer ;
122 : timestamp>http-string ( timestamp -- str )
123 ! http timestamp format
124 ! Example: Tue, 15 Nov 1994 08:12:31 GMT
125 >gmt timestamp>rfc822 ;
127 : (timestamp>cookie-string) ( timestamp -- )
129 { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
131 : timestamp>cookie-string ( timestamp -- str )
132 [ (timestamp>cookie-string) ] with-string-writer ;
134 : (write-rfc3339-gmt-offset) ( duration -- )
135 [ hh ":" write ] [ mm ] bi ;
137 : write-rfc3339-gmt-offset ( duration -- )
139 { +eq+ [ drop "Z" write ] }
140 { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
141 { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
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 ;
149 : (timestamp>rfc3339) ( timestamp -- )
151 YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
152 [ gmt-offset>> write-rfc3339-gmt-offset ]
155 : timestamp>rfc3339 ( timestamp -- str )
156 [ (timestamp>rfc3339) ] with-string-writer ;
158 : (timestamp>ymd) ( timestamp -- )
159 { YYYY "-" MM "-" DD } formatted ;
161 TYPED: timestamp>ymd ( timestamp: timestamp -- str )
162 [ (timestamp>ymd) ] with-string-writer ;
164 : (timestamp>hms) ( timestamp -- )
165 { hh ":" mm ":" ss } formatted ;
167 TYPED: timestamp>hms ( timestamp: timestamp -- str )
168 [ (timestamp>hms) ] with-string-writer ;
170 : (timestamp>hm) ( timestamp -- )
171 { hh ":" mm } formatted ;
173 TYPED: timestamp>hm ( timestamp: timestamp -- str )
174 [ (timestamp>hm) ] with-string-writer ;
176 TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
179 { (timestamp>ymd) " " (timestamp>hms) } formatted
180 ] with-string-writer ;
182 : file-time-string ( timestamp -- string )
187 dup now [ year>> ] same?
188 [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
191 ] with-string-writer ;
193 M: timestamp present timestamp>string ;
195 TYPED: duration>hm ( duration: duration -- string )
196 [ duration>hours >integer 24 mod pad-00 ]
197 [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
199 TYPED: duration>human-readable ( duration: duration -- string )
202 duration>years >integer
204 [ number>string write ]
205 [ 1 > " years, " " year, " ? write ] bi
208 duration>days >integer 365 mod
210 [ number>string write ]
211 [ 1 > " days, " " day, " ? write ] bi
213 ] [ duration>hm write ] tri
214 ] with-string-writer ;