! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar calendar.format.macros
-combinators io io.streams.string kernel math math.functions
-math.order math.parser present sequences typed ;
+! See https://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.english combinators
+formatting grouping io io.streams.string kernel make math
+math.order math.parser present quotations ranges sequences
+splitting strings words ;
IN: calendar.format
+MACRO: formatted ( spec -- quot )
+ [
+ {
+ { [ dup word? ] [ 1quotation ] }
+ { [ dup quotation? ] [ ] }
+ [ [ nip write ] curry ]
+ } cond
+ ] map [ cleave ] curry ;
+
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
-: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
-
: write-00 ( n -- ) pad-00 write ;
: write-0000 ( n -- ) pad-0000 write ;
-: write-00000 ( n -- ) pad-00000 write ;
+: hh ( timestamp -- ) hour>> write-00 ;
-: hh ( time -- ) hour>> write-00 ;
+: mm ( timestamp -- ) minute>> write-00 ;
-: mm ( time -- ) minute>> write-00 ;
+: ss ( timestamp -- ) second>> >integer write-00 ;
-: ss ( time -- ) second>> >integer write-00 ;
+: ss.SSSSSS ( timestamp -- ) second>> "%09.6f" printf ;
-: D ( time -- ) day>> number>string write ;
+: hhmm ( timestamp -- ) [ hh ] [ mm ] bi ;
-: DD ( time -- ) day>> write-00 ;
+: hh:mm ( timestamp -- ) { hh ":" mm } formatted ;
-: DAY ( time -- ) day-of-week day-abbreviation3 write ;
+: hh:mm:ss ( timestamp -- ) { hh ":" mm ":" ss } formatted ;
-: MM ( time -- ) month>> write-00 ;
+: hh:mm:ss.SSSSSS ( timestamp -- ) { hh ":" mm ":" ss.SSSSSS } formatted ;
-: MONTH ( time -- ) month>> month-abbreviation write ;
+: D ( timestamp -- ) day>> number>string write ;
-: YYYY ( time -- ) year>> write-0000 ;
+: DD ( timestamp -- ) day>> write-00 ;
-: YYYYY ( time -- ) year>> write-00000 ;
+: DAY ( timestamp -- ) day-of-week day-abbreviation3 write ;
-: expect ( str -- )
- read1 swap member? [ "Parse error" throw ] unless ;
+: MM ( timestamp -- ) month>> write-00 ;
-: read-00 ( -- n ) 2 read string>number ;
+: MONTH ( timestamp -- ) month>> month-abbreviation write ;
-: read-000 ( -- n ) 3 read string>number ;
+: YYYY ( timestamp -- ) year>> write-0000 ;
-: read-0000 ( -- n ) 4 read string>number ;
-
-: hhmm>timestamp ( hhmm -- timestamp )
- [
- 0 0 0 read-00 read-00 0 instant <timestamp>
- ] with-string-reader ;
+: YYYY-MM-DD ( timestamp -- ) { YYYY "-" MM "-" DD } formatted ;
GENERIC: day. ( obj -- )
-M: integer day. ( n -- )
+M: integer day.
number>string dup length 2 < [ bl ] when write ;
-M: timestamp day. ( timestamp -- )
+M: timestamp day.
day>> day. ;
-GENERIC: month. ( obj -- )
+<PRIVATE
-M: array month. ( pair -- )
- first2
- [ month-name write bl number>string print ]
- [ 1 zeller-congruence ]
- [ (days-in-month) day-abbreviations2 " " join print ] 2tri
- over " " <repetition> "" concat-as write
- [
- [ 1 + day. ] keep
- 1 + + 7 mod zero? [ nl ] [ bl ] if
- ] with each-integer nl ;
+: center. ( str n -- )
+ over length [-] 2/ CHAR: \s <string> write print ;
+
+: month-header. ( year month -- )
+ [ number>string ] [ month-name ] bi* swap " " glue 20 center. ;
-M: timestamp month. ( timestamp -- )
- [ year>> ] [ month>> ] bi 2array month. ;
+: days-header. ( -- )
+ day-abbreviations2 join-words print ;
+
+: days. ( year month -- )
+ [ 1 (day-of-week) dup [ " " write ] times ]
+ [ (days-in-month) ] 2bi [1..b] [
+ [ day. ] [ + 7 mod zero? [ nl ] [ bl ] if ] bi
+ ] with each nl ;
+
+PRIVATE>
+
+: month. ( timestamp -- )
+ [ year>> ] [ month>> ] bi
+ [ month-header. ] [ days-header. days. ] 2bi ;
GENERIC: year. ( obj -- )
-M: integer year. ( n -- )
- 12 [ 1 + 2array month. nl ] with each-integer ;
+M: integer year.
+ dup number>string 64 center. nl 12 [1..b] [
+ [
+ [ month-name 20 center. ]
+ [ days-header. days. nl nl ] bi
+ ] with-string-writer split-lines
+ ] with map 3 <groups>
+ [ first3 [ "%-20s %-20s %-20s\n" printf ] 3each ] each ;
-M: timestamp year. ( timestamp -- )
- year>> year. ;
+M: timestamp year. year>> year. ;
: timestamp>mdtm ( timestamp -- str )
[ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
-: (timestamp>string) ( timestamp -- )
- { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
+: timestamp>ymd ( timestamp -- str )
+ [ YYYY-MM-DD ] with-string-writer ;
-: timestamp>string ( timestamp -- str )
- [ (timestamp>string) ] with-string-writer ;
+: timestamp>hms ( timestamp -- str )
+ [ hh:mm:ss ] with-string-writer ;
-: (write-gmt-offset) ( duration -- )
- [ hh ] [ mm ] bi ;
+: timestamp>ymdhms ( timestamp -- str )
+ [ >gmt { YYYY-MM-DD " " hh:mm:ss } formatted ] with-string-writer ;
-: write-gmt-offset ( gmt-offset -- )
- dup instant <=> {
- { +eq+ [ drop "GMT" write ] }
- { +lt+ [ "-" write before (write-gmt-offset) ] }
- { +gt+ [ "+" write (write-gmt-offset) ] }
- } case ;
-
-: timestamp>rfc822 ( timestamp -- str )
- #! RFC822 timestamp format
- #! Example: Tue, 15 Nov 1994 08:12:31 +0200
- [
- [ (timestamp>string) bl ]
- [ gmt-offset>> write-gmt-offset ]
- bi
- ] with-string-writer ;
+: write-gmt-offset-hhmm ( gmt-offset -- )
+ [ hour>> dup 0 < "-" "+" ? write abs write-00 ] [ mm ] bi ;
-: timestamp>http-string ( timestamp -- str )
- #! http timestamp format
- #! Example: Tue, 15 Nov 1994 08:12:31 GMT
- >gmt timestamp>rfc822 ;
+: write-gmt-offset-hh:mm ( gmt-offset -- )
+ [ hour>> dup 0 < "-" "+" ? write abs write-00 ":" write ] [ mm ] bi ;
-: (timestamp>cookie-string) ( timestamp -- )
- >gmt
- { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
+: write-gmt-offset ( gmt-offset -- )
+ dup instant = [ drop "GMT" write ] [ write-gmt-offset-hhmm ] if ;
-: timestamp>cookie-string ( timestamp -- str )
- [ (timestamp>cookie-string) ] with-string-writer ;
+: write-gmt-offset-z ( gmt-offset -- )
+ dup instant = [ drop "Z" write ] [ write-gmt-offset-hh:mm ] if ;
+
+: write-rfc1036 ( timestamp -- )
+ {
+ DAY ", " DD "-" MONTH "-" YYYY " " hh:mm:ss " "
+ [ gmt-offset>> write-gmt-offset ]
+ } formatted ;
-: (write-rfc3339-gmt-offset) ( duration -- )
- [ hh ":" write ] [ mm ] bi ;
+: timestamp>rfc1036 ( timestamp -- str )
+ [ write-rfc1036 ] with-string-writer ;
-: write-rfc3339-gmt-offset ( duration -- )
- dup instant <=> {
- { +eq+ [ drop "Z" write ] }
- { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] }
- { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] }
- } case ;
+! RFC850 obsoleted by RFC1036
+ALIAS: write-rfc850 write-rfc1036
+ALIAS: timestamp>rfc850 timestamp>rfc1036
-: (timestamp>rfc3339) ( timestamp -- )
+: write-rfc2822 ( timestamp -- )
{
- YYYY "-" MM "-" DD "T" hh ":" mm ":" ss
- [ gmt-offset>> write-rfc3339-gmt-offset ]
+ DAY ", " D " " MONTH " " YYYY " " hh:mm:ss " "
+ [ gmt-offset>> write-gmt-offset ]
} formatted ;
-: timestamp>rfc3339 ( timestamp -- str )
- [ (timestamp>rfc3339) ] with-string-writer ;
+: timestamp>rfc2822 ( timestamp -- str )
+ [ write-rfc2822 ] with-string-writer ;
-: signed-gmt-offset ( dt ch -- dt' )
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
+! RFC822 obsoleted by RFC2822
+ALIAS: write-rfc822 write-rfc2822
+ALIAS: timestamp>rfc822 timestamp>rfc2822
-: read-rfc3339-gmt-offset ( ch -- dt )
+: write-rfc3339 ( timestamp -- )
{
- { f [ instant ] }
- { CHAR: Z [ instant ] }
- [
- [
- read-00 hours
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
- time+
- ] dip signed-gmt-offset
- ]
- } case ;
-
-: read-ymd ( -- y m d )
- read-0000 "-" expect read-00 "-" expect read-00 ;
-
-: read-hms ( -- h m s )
- read-00 ":" expect read-00 ":" expect read-00 ;
-
-: read-rfc3339-seconds ( s -- s' ch )
- "+-Z" read-until [
- [ string>number ] [ length 10^ ] bi / +
- ] dip ;
-
-: (rfc3339>timestamp) ( -- timestamp )
- read-ymd
- "Tt \t" expect
- read-hms
- read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
- read-rfc3339-gmt-offset
- <timestamp> ;
-
-: rfc3339>timestamp ( str -- timestamp )
- [ (rfc3339>timestamp) ] with-string-reader ;
-
-ERROR: invalid-timestamp-format ;
-
-: check-timestamp ( obj/f -- obj )
- [ invalid-timestamp-format ] unless* ;
-
-: read-token ( seps -- token )
- [ read-until ] keep member? check-timestamp drop ;
-
-: read-sp ( -- token ) " " read-token ;
-
-: checked-number ( str -- n )
- string>number check-timestamp ;
-
-: parse-rfc822-gmt-offset ( string -- dt )
- dup "GMT" = [ drop instant ] [
- unclip [
- 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
- ] dip signed-gmt-offset
- ] if ;
-
-: (rfc822>timestamp) ( -- timestamp )
- timestamp new
- "," read-token day-abbreviations3 member? check-timestamp drop
- read1 CHAR: \s assert=
- read-sp checked-number >>day
- read-sp month-abbreviations index 1 + check-timestamp >>month
- read-sp checked-number >>year
- ":" read-token checked-number >>hour
- ":" read-token checked-number >>minute
- read-sp checked-number >>second
- readln parse-rfc822-gmt-offset >>gmt-offset ;
-
-: rfc822>timestamp ( str -- timestamp )
- [ (rfc822>timestamp) ] with-string-reader ;
-
-: check-day-name ( str -- )
- [ day-abbreviations3 member? ] [ day-names member? ] bi or
- check-timestamp drop ;
-
-: (cookie-string>timestamp-1) ( -- timestamp )
- timestamp new
- "," read-token check-day-name
- read1 CHAR: \s assert=
- "-" read-token checked-number >>day
- "-" read-token month-abbreviations index 1 + check-timestamp >>month
- read-sp checked-number >>year
- ":" read-token checked-number >>hour
- ":" read-token checked-number >>minute
- read-sp checked-number >>second
- readln parse-rfc822-gmt-offset >>gmt-offset ;
-
-: cookie-string>timestamp-1 ( str -- timestamp )
- [ (cookie-string>timestamp-1) ] with-string-reader ;
-
-: (cookie-string>timestamp-2) ( -- timestamp )
- timestamp new
- read-sp check-day-name
- read-sp month-abbreviations index 1 + check-timestamp >>month
- read-sp checked-number >>day
- ":" read-token checked-number >>hour
- ":" read-token checked-number >>minute
- read-sp checked-number >>second
- read-sp checked-number >>year
- readln parse-rfc822-gmt-offset >>gmt-offset ;
-
-: cookie-string>timestamp-2 ( str -- timestamp )
- [ (cookie-string>timestamp-2) ] with-string-reader ;
-
-: cookie-string>timestamp ( str -- timestamp )
- {
- [ cookie-string>timestamp-1 ]
- [ cookie-string>timestamp-2 ]
- [ rfc822>timestamp ]
- } attempt-all-quots ;
+ YYYY-MM-DD "T" hh:mm:ss.SSSSSS
+ [ gmt-offset>> write-gmt-offset-z ]
+ } formatted ;
-: (ymdhms>timestamp) ( -- timestamp )
- read-ymd " " expect read-hms instant <timestamp> ;
+: timestamp>rfc3339 ( timestamp -- str )
+ [ write-rfc3339 ] with-string-writer ;
-: ymdhms>timestamp ( str -- timestamp )
- [ (ymdhms>timestamp) ] with-string-reader ;
+: write-iso8601 ( timestamp -- )
+ {
+ YYYY-MM-DD "T" hh:mm:ss.SSSSSS
+ [ gmt-offset>> write-gmt-offset-hh:mm ]
+ } formatted ;
-: (hms>timestamp) ( -- timestamp )
- 0 0 0 read-hms instant <timestamp> ;
+: timestamp>iso8601 ( timestamp -- str )
+ [ write-iso8601 ] with-string-writer ;
-: hms>timestamp ( str -- timestamp )
- [ (hms>timestamp) ] with-string-reader ;
+: write-ctime ( timestamp -- )
+ {
+ DAY " " MONTH " " DD " " hh:mm:ss " " YYYY
+ } formatted ;
-: (ymd>timestamp) ( -- timestamp )
- read-ymd <date-gmt> ;
+: timestamp>ctime-string ( timestamp -- str )
+ [ write-ctime ] with-string-writer ;
-: ymd>timestamp ( str -- timestamp )
- [ (ymd>timestamp) ] with-string-reader ;
+: timestamp>git-string ( timestamp -- str )
+ [
+ {
+ DAY " " MONTH " " D " " hh:mm:ss " " YYYY " "
+ [ gmt-offset>> write-gmt-offset-hhmm ]
+ } formatted
+ ] with-string-writer ;
-: (timestamp>ymd) ( timestamp -- )
- { YYYY "-" MM "-" DD } formatted ;
+: timestamp>http-string ( timestamp -- str )
+ >gmt timestamp>rfc2822 ;
-TYPED: timestamp>ymd ( timestamp: timestamp -- str )
- [ (timestamp>ymd) ] with-string-writer ;
+: timestamp>cookie-string ( timestamp -- str )
+ >gmt timestamp>rfc1036 ;
-: (timestamp>hms) ( timestamp -- )
- { hh ":" mm ":" ss } formatted ;
+: write-timestamp ( timestamp -- )
+ { DAY ", " D " " MONTH " " YYYY " " hh:mm:ss } formatted ;
-TYPED: timestamp>hms ( timestamp: timestamp -- str )
- [ (timestamp>hms) ] with-string-writer ;
+: timestamp>string ( timestamp -- str )
+ [ write-timestamp ] with-string-writer ;
-: (timestamp>hm) ( timestamp -- )
- { hh ":" mm } formatted ;
+M: timestamp present timestamp>string ;
-TYPED: timestamp>hm ( timestamp: timestamp -- str )
- [ (timestamp>hm) ] with-string-writer ;
+: duration>hm ( duration -- str )
+ [ duration>hours >integer 24 mod pad-00 ]
+ [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
-TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
- [
- >gmt
- { (timestamp>ymd) " " (timestamp>hms) } formatted
- ] with-string-writer ;
+: duration>hms ( duration -- str )
+ [ duration>hm ]
+ [ duration>seconds >integer 60 mod pad-00 ] bi ":" glue ;
-: file-time-string ( timestamp -- string )
+: duration>human-readable ( duration -- string )
[
{
- MONTH " " DD " "
[
- dup now [ year>> ] same?
- [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
+ duration>years >integer
+ [
+ [ number>string ]
+ [ 1 > " years" " year" ? append , ] bi
+ ] unless-zero
+ ] [
+ duration>days >integer 365 mod
+ [
+ [ number>string ]
+ [ 1 > " days" " day" ? append , ] bi
+ ] unless-zero
+ ] [
+ duration>hours >integer 24 mod
+ [
+ [ number>string ]
+ [ 1 > " hours" " hour" ? append , ] bi
+ ] unless-zero
+ ] [
+ duration>minutes >integer 60 mod
+ [
+ [ number>string ]
+ [ 1 > " minutes" " minute" ? append , ] bi
+ ] unless-zero
+ ] [
+ duration>seconds >integer 60 mod
+ [
+ number>string " seconds" append ,
+ ] unless-zero
]
- } formatted
- ] with-string-writer ;
-
-M: timestamp present timestamp>string ;
+ } cleave
+ ] { } make [ "0 seconds" ] [
+ unclip-last-slice over empty? [ nip ] [
+ [ ", " join ] [ " and " glue ] bi*
+ ] if
+ ] if-empty ;
-TYPED: duration>hm ( duration: duration -- string )
- [ duration>hours >integer 24 mod pad-00 ]
- [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
+GENERIC: elapsed-time ( seconds -- string )
-TYPED: duration>human-readable ( duration: duration -- string )
- [
- [
- duration>years >integer
- [
- [ number>string write ]
- [ 1 > " years, " " year, " ? write ] bi
- ] unless-zero
+M: integer elapsed-time
+ dup 0 < [ "negative seconds" throw ] when [
+ {
+ { 60 "s" }
+ { 60 "m" }
+ { 24 "h" }
+ { 7 "d" }
+ { 52 "w" }
+ { f "y" }
+ } [
+ [ first [ /mod ] [ dup ] if* ] [ second ] bi swap
+ dup 0 > [ number>string prepend , ] [ 2drop ] if
+ ] each drop
+ ] { } make [ "0s" ] [ reverse join-words ] if-empty ;
+
+M: real elapsed-time
+ >integer elapsed-time ;
+
+M: duration elapsed-time
+ duration>seconds elapsed-time ;
+
+M: timestamp elapsed-time
+ ago elapsed-time ;
+
+: relative-time-offset ( seconds -- string )
+ abs {
+ { [ dup 1 < ] [ drop "just now" ] }
+ { [ dup 60 < ] [ drop "less than a minute" ] }
+ { [ dup 120 < ] [ drop "about a minute" ] }
+ { [ dup 2700 < ] [ 60 /i "%d minutes" sprintf ] }
+ { [ dup 7200 < ] [ drop "about an hour" ] }
+ { [ dup 86400 < ] [ 3600 /i "%d hours" sprintf ] }
+ { [ dup 172800 < ] [ drop "1 day" ] }
+ [ 86400 /i "%d days" sprintf ]
+ } cond ;
+
+GENERIC: relative-time ( seconds -- string )
+
+M: real relative-time
+ [ relative-time-offset ] [
+ dup abs 1 < [
+ drop
] [
- duration>days >integer 365 mod
- [
- [ number>string write ]
- [ 1 > " days, " " day, " ? write ] bi
- ] unless-zero
- ] [ duration>hm write ] tri
- ] with-string-writer ;
+ 0 < "hence" "ago" ? " " glue
+ ] if
+ ] bi ;
+
+M: duration relative-time
+ duration>seconds relative-time ;
+
+M: timestamp relative-time
+ ago relative-time ;
projects / factor.git / blobdiff