calendar: change >gmt, >local-time to clone.

[factor.git] / basis / calendar / format / format.factor

diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor
index 6c602008c4c20ada349b2e5d3ec093f9760a474f..9126352769e0f7805ce3f1bd8a8580c38d9f3b45 100644 (file)
--- a/basis/calendar/format/format.factor
+++ b/basis/calendar/format/format.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar calendar.english combinators io
-io.streams.string kernel math math.parser math.parser.private
-present quotations sequences words ;
+USING: accessors arrays calendar calendar.english combinators
+formatting grouping io io.streams.string kernel make math
+math.order math.parser math.parser.private math.ranges present
+quotations sequences splitting strings words ;
 IN: calendar.format
 
 MACRO: formatted ( spec -- quot )
@@ -63,26 +64,39 @@ M: integer day.
 M: timestamp day.
     day>> day. ;
 
-GENERIC: month. ( obj -- )
+<PRIVATE
 
-M: array month.
-    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. ;
+
+: days-header. ( -- )
+    day-abbreviations2 " " join print ;
 
-M: timestamp month.
-    [ year>> ] [ month>> ] bi 2array month. ;
+: 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.
-    12 [ 1 + 2array month. nl ] with each-integer ;
+    dup number>string 64 center. nl 12 [1,b] [
+        [
+            [ month-name 20 center. ]
+            [ days-header. days. nl nl ] bi
+        ] with-string-writer string-lines
+    ] with map 3 <groups>
+    [ first3 [ "%-20s  %-20s  %-20s\n" printf ] 3each ] each ;
 
 M: timestamp year. year>> year. ;
 
@@ -112,7 +126,7 @@ M: timestamp year. year>> year. ;
 
 : write-rfc1036 ( timestamp -- )
     {
-        DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " "
+        DAY ", " DD "-" MONTH "-" YYYY " " hh:mm:ss " "
         [ gmt-offset>> write-gmt-offset ]
     } formatted ;
 
@@ -125,7 +139,7 @@ ALIAS: timestamp>rfc850 timestamp>rfc1036
 
 : write-rfc2822 ( timestamp -- )
     {
-        DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss " "
+        DAY ", " D " " MONTH " " YYYY " " hh:mm:ss " "
         [ gmt-offset>> write-gmt-offset ]
     } formatted ;
 
@@ -138,7 +152,7 @@ ALIAS: timestamp>rfc822 timestamp>rfc2822
 
 : write-rfc3339 ( timestamp -- )
     {
-        YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
+        YYYY-MM-DD "T" hh:mm:ss.SSSSSS
         [ gmt-offset>> write-gmt-offset-z ]
     } formatted ;
 
@@ -147,7 +161,7 @@ ALIAS: timestamp>rfc822 timestamp>rfc2822
 
 : write-iso8601 ( timestamp -- )
     {
-        YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
+        YYYY-MM-DD "T" hh:mm:ss.SSSSSS
         [ gmt-offset>> write-gmt-offset-hh:mm ]
     } formatted ;
 
@@ -156,7 +170,7 @@ ALIAS: timestamp>rfc822 timestamp>rfc2822
 
 : write-ctime ( timestamp -- )
     {
-        DAY " " MONTH " " DD " " hh ":" mm ":" ss " " YYYY
+        DAY " " MONTH " " DD " " hh:mm:ss " " YYYY
     } formatted ;
 
 : timestamp>ctime-string ( timestamp -- str )
@@ -165,7 +179,7 @@ ALIAS: timestamp>rfc822 timestamp>rfc2822
 : timestamp>git-string ( timestamp -- str )
     [
         {
-            DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " "
+            DAY " " MONTH " " D " " hh:mm:ss " " YYYY " "
             [ gmt-offset>> write-gmt-offset-hhmm ]
         } formatted
     ] with-string-writer ;
@@ -177,7 +191,7 @@ ALIAS: timestamp>rfc822 timestamp>rfc2822
     >gmt timestamp>rfc1036 ;
 
 : write-timestamp ( timestamp -- )
-    { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
+    { DAY ", " D " " MONTH " " YYYY " " hh:mm:ss } formatted ;
 
 : timestamp>string ( timestamp -- str )
     [ write-timestamp ] with-string-writer ;
@@ -189,7 +203,8 @@ M: timestamp present timestamp>string ;
     [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
 
 : duration>hms ( duration -- str )
-    [ duration>hm ] [ second>> >integer 60 mod pad-00 ] bi ":" glue ;
+    [ duration>hm ]
+    [ duration>seconds >integer 60 mod pad-00 ] bi ":" glue ;
 
 : duration>human-readable ( duration -- string )
     [
@@ -207,3 +222,59 @@ M: timestamp present timestamp>string ;
             ] unless-zero
         ] [ duration>hms write ] tri
     ] with-string-writer ;
+
+GENERIC: elapsed-time ( seconds -- string )
+
+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 ] if-empty ;
+
+M: real elapsed-time
+    >integer elapsed-time ;
+
+M: duration elapsed-time
+    duration>seconds elapsed-time ;
+
+M: timestamp elapsed-time
+    now swap time- elapsed-time ;
+
+! XXX: Anything up to 2 hours is "about an hour"
+: 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
+        ] [
+            0 < "hence" "ago" ? " " glue
+        ] if
+    ] bi ;
+
+M: duration relative-time
+    duration>seconds relative-time ;
+
+M: timestamp relative-time
+    now swap time- relative-time ;