calendar: some cleanup to format and parser.

diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor
index c910089109bee646c94807713ed1cd214552361c..bc88725e1804a3f0112cc120c548bdd223cddde1 100644 (file)
--- a/basis/calendar/format/format.factor
+++ b/basis/calendar/format/format.factor
@@ -1,9 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar calendar.english combinators
-fry io io.streams.string kernel macros math math.order
-math.parser math.parser.private present quotations sequences
-typed words ;
+USING: accessors arrays calendar calendar.english combinators io
+io.streams.string kernel math math.parser math.parser.private
+present quotations sequences words ;
 IN: calendar.format
 
 MACRO: formatted ( spec -- quot )
@@ -15,40 +14,46 @@ MACRO: formatted ( spec -- quot )
         } cond
     ] map [ cleave ] curry ;
 
-: formatted>string ( spec -- string )
-    '[ _ formatted ] with-string-writer ; inline
-
 : 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 ;
+
+! Should be enough for anyone, allows to not do a fancy
+! algorithm to detect infinite decimals (e.g 1/3)
+: ss.SSSSSS ( timestamp -- )
+    second>> >float "0" 9 6 "f" "C" format-float write ;
 
-: ss ( time -- ) second>> >integer write-00 ;
+: hhmm ( timestamp -- ) [ hh ] [ mm ] bi ;
 
-: D ( time -- ) day>> number>string write ;
+: hh:mm ( timestamp -- ) { hh ":" mm } formatted ;
 
-: DD ( time -- ) day>> write-00 ;
+: hh:mm:ss ( timestamp -- ) { hh ":" mm ":" ss } formatted ;
 
-: DAY ( time -- ) day-of-week day-abbreviation3 write ;
+: hh:mm:ss.SSSSSS ( timestamp -- ) { hh ":" mm ":" ss.SSSSSS } formatted ;
 
-: MM ( time -- ) month>> write-00 ;
+: D ( timestamp -- ) day>> number>string write ;
 
-: MONTH ( time -- ) month>> month-abbreviation write ;
+: DD ( timestamp -- ) day>> write-00 ;
 
-: YYYY ( time -- ) year>> write-0000 ;
+: DAY ( timestamp -- ) day-of-week day-abbreviation3 write ;
 
-: YYYYY ( time -- ) year>> write-00000 ;
+: MM ( timestamp -- ) month>> write-00 ;
+
+: MONTH ( timestamp -- ) month>> month-abbreviation write ;
+
+: YYYY ( timestamp -- ) year>> write-0000 ;
+
+: YYYY-MM-DD ( timestamp -- ) { YYYY "-" MM "-" DD } formatted ;
 
 GENERIC: day. ( obj -- )
 
@@ -84,139 +89,100 @@ 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 ;
+
+: timestamp>ymdhms ( timestamp -- str )
+    [ >gmt YYYY-MM-DD " " hh:mm:ss ] with-string-writer ;
+
+: write-gmt-offset-hhmm ( gmt-offset -- )
+    [ hour>> dup 0 < "-" "+" ? write abs write-00 ] [ mm ] bi ;
 
-: write-hhmm ( duration -- )
-    [ hh ] [ mm ] bi ;
+: write-gmt-offset-hh:mm ( gmt-offset -- )
+    [ hour>> dup 0 < "-" "+" ? write abs write-00 ":" write ] [ mm ] bi ;
 
 : write-gmt-offset ( gmt-offset -- )
-    dup instant <=> {
-        { +eq+ [ drop "GMT" write ] }
-        { +lt+ [ "-" write before write-hhmm ] }
-        { +gt+ [ "+" write write-hhmm ] }
-    } case ;
-
-: write-gmt-offset-number ( gmt-offset -- )
-    dup instant <=> {
-        { +eq+ [ drop "+0000" write ] }
-        { +lt+ [ "-" write before write-hhmm ] }
-        { +gt+ [ "+" write write-hhmm ] }
-    } 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 ;
+    dup instant = [ drop "GMT" write ] [ write-gmt-offset-hhmm ] if ;
 
-: timestamp>git-time ( timestamp -- str )
-    [
-        [ { DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " " } formatted ]
-        [ gmt-offset>> write-gmt-offset-number ] bi
-    ] with-string-writer ;
+: write-gmt-offset-z ( gmt-offset -- )
+    dup instant = [ drop "Z" write ] [ write-gmt-offset-hh:mm ] if ;
 
-: timestamp>http-string ( timestamp -- str )
-    ! http timestamp format
-    ! Example: Tue, 15 Nov 1994 08:12:31 GMT
-    >gmt timestamp>rfc822 ;
+: write-rfc1036 ( timestamp -- )
+    {
+        DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " "
+        [ gmt-offset>> write-gmt-offset ]
+    } formatted ;
 
-: (timestamp>cookie-string) ( timestamp -- )
-    >gmt
-    { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ;
+: timestamp>rfc1036 ( timestamp -- str )
+    [ write-rfc1036 ] with-string-writer ;
 
-: timestamp>cookie-string ( timestamp -- str )
-    [ (timestamp>cookie-string) ] with-string-writer ;
+! RFC850 obsoleted by RFC1036
+ALIAS: write-rfc850 write-rfc1036
+ALIAS: timestamp>rfc850 timestamp>rfc1036
 
-: (write-rfc3339-gmt-offset) ( duration -- )
-    [ hh ":" write ] [ mm ] bi ;
+: write-rfc2822 ( timestamp -- )
+    {
+        DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss " "
+        [ gmt-offset>> write-gmt-offset ]
+    } formatted ;
 
-: 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 ;
+: timestamp>rfc2822 ( timestamp -- str )
+    [ write-rfc2822 ] with-string-writer ;
 
-! Should be enough for anyone, allows to not do a fancy
-! algorithm to detect infinite decimals (e.g 1/3)
-: ss.SSSSSS ( timestamp -- )
-    second>> >float "0" 9 6 "f" "C" format-float write ;
+! RFC822 obsoleted by RFC2822
+ALIAS: write-rfc822 write-rfc2822
+ALIAS: timestamp>rfc822 timestamp>rfc2822
 
-: (timestamp>rfc3339) ( timestamp -- )
+: write-rfc3339 ( timestamp -- )
     {
         YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
-        [ gmt-offset>> write-rfc3339-gmt-offset ]
+        [ gmt-offset>> write-gmt-offset-z ]
     } formatted ;
 
 : timestamp>rfc3339 ( timestamp -- str )
-    [ (timestamp>rfc3339) ] with-string-writer ;
+    [ write-rfc3339 ] with-string-writer ;
 
-: (write-rfc2822-gmt-offset) ( duration -- )
-    [ hh ":" write ] [ mm ] bi ;
-
-: write-rfc2822-gmt-offset ( duration -- )
-    dup instant <=> {
-        { +lt+ [ "-" write before (write-rfc2822-gmt-offset) ] }
-        { +gt+ [ "+" write (write-rfc2822-gmt-offset) ] }
-        { +eq+ [ "+" write (write-rfc2822-gmt-offset) ] }
-    } case ;
-
-: (timestamp>rfc2822) ( timestamp -- )
+: write-iso8601 ( timestamp -- )
     {
-        DAY ", " DD " " MONTH " " YYYY " " hh ":" mm ":" ss " "
-        [ gmt-offset>> write-rfc2822-gmt-offset ]
+        YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS
+        [ gmt-offset>> write-gmt-offset-hh:mm ]
     } formatted ;
 
-: timestamp>rfc2822 ( timestamp -- str )
-    [ (timestamp>rfc2822) ] with-string-writer ;
-
-: (timestamp>ymd) ( timestamp -- )
-    { YYYY "-" MM "-" DD } formatted ;
-
-TYPED: timestamp>ymd ( timestamp: timestamp -- str )
-    [ (timestamp>ymd) ] with-string-writer ;
+: timestamp>iso8601 ( timestamp -- str )
+    [ write-iso8601 ] with-string-writer ;
 
-: (timestamp>hms) ( timestamp -- )
-    { hh ":" mm ":" ss } formatted ;
-
-TYPED: timestamp>hms ( timestamp: timestamp -- str )
-    [ (timestamp>hms) ] with-string-writer ;
-
-TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
+: timestamp>git-string ( timestamp -- str )
     [
-        >gmt
-        { (timestamp>ymd) " " (timestamp>hms) } formatted
+        {
+            DAY " " MONTH " " D " " hh ":" mm ":" ss " " YYYY " "
+            [ gmt-offset>> write-gmt-offset-hhmm ]
+        } formatted
     ] with-string-writer ;
 
-: file-time-string ( timestamp -- string )
+: timestamp>http-string ( timestamp -- str )
+    >gmt timestamp>rfc2822 ;
+
+: timestamp>cookie-string ( timestamp -- str )
+    >gmt timestamp>rfc1036 ;
+
+: timestamp>string ( timestamp -- str )
     [
-        {
-            MONTH " " DD " "
-            [
-                dup now [ year>> ] same?
-                [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if
-            ]
-        } formatted
+        { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted
     ] with-string-writer ;
 
 M: timestamp present timestamp>string ;
 
-! Duration formatting
-TYPED: duration>hm ( duration: duration -- str )
+: duration>hm ( duration -- str )
     [ duration>hours >integer 24 mod pad-00 ]
     [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ;
 
-TYPED: duration>hms ( duration: duration -- str )
+: duration>hms ( duration -- str )
     [ duration>hm ] [ second>> >integer 60 mod pad-00 ] bi ":" glue ;
 
-TYPED: duration>human-readable ( duration: duration -- string )
+: duration>human-readable ( duration -- string )
     [
         [
             duration>years >integer

diff --git a/basis/calendar/parser/parser-tests.factor b/basis/calendar/parser/parser-tests.factor
index b97e2bdfed757c63c9228bd5447dc6b2c882a9d7..78b673428440e307d056d54d8ecea7fd366547c4 100644 (file)
--- a/basis/calendar/parser/parser-tests.factor
+++ b/basis/calendar/parser/parser-tests.factor
@@ -1,20 +1,5 @@
 USING: accessors calendar calendar.format calendar.parser io
 io.streams.string kernel math.order tools.test ;
-IN: calendar.parser.tests
-
-! attempt-all-quots
-{ 2 } [ { [ 2 ] } attempt-all-quots ] unit-test
-
-{ 2 } [ { [ 1 throw ] [ 2 ] } attempt-all-quots ] unit-test
-
-[ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with
-
-: compiled-test-1 ( -- n )
-    { [ 1 throw ] [ 2 ] } attempt-all-quots ;
-
-\ compiled-test-1 def>> must-infer
-
-{ 2 } [ compiled-test-1 ] unit-test
 
 ! cookie-string>timestamp
 {

diff --git a/basis/calendar/parser/parser.factor b/basis/calendar/parser/parser.factor
index 648115a1fbda76901707900f7d0dc59f6cdb6070..51ee54fd01efb6eef1698590ae2c8a671bb99436 100644 (file)
--- a/basis/calendar/parser/parser.factor
+++ b/basis/calendar/parser/parser.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs calendar calendar.english combinators
-continuations generalizations io io.streams.string kernel macros math
-math.functions math.parser sequences ;
+combinators.short-circuit continuations generalizations io
+io.streams.string kernel math math.functions math.parser
+sequences ;
 IN: calendar.parser
 
 : read-00 ( -- n ) 2 read string>number ;
@@ -54,7 +55,7 @@ ERROR: invalid-timestamp-format ;
         [ string>number ] [ length 10^ ] bi / +
     ] dip ;
 
-: (rfc3339>timestamp) ( -- timestamp )
+: read-rfc3339 ( -- timestamp )
     read-ymd
     "Tt \t" expect
     read-hms
@@ -63,7 +64,7 @@ ERROR: invalid-timestamp-format ;
     <timestamp> ;
 
 : rfc3339>timestamp ( str -- timestamp )
-    [ (rfc3339>timestamp) ] with-string-reader ;
+    [ read-rfc3339 ] with-string-reader ;
 
 : parse-rfc822-military-offset ( string -- dt )
     first CHAR: A - {
@@ -99,7 +100,7 @@ CONSTANT: rfc822-named-zones H{
     ":" read-token checked-number
     read-sp checked-number ;
 
-: (rfc822>timestamp) ( -- timestamp )
+: read-rfc822 ( -- timestamp )
     "," read-token day-abbreviations3 member? check-timestamp drop
     read1 CHAR: \s assert=
     read-sp checked-number
@@ -109,13 +110,13 @@ CONSTANT: rfc822-named-zones H{
     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 
 : rfc822>timestamp ( str -- timestamp )
-    [ (rfc822>timestamp) ] with-string-reader ;
+    [ read-rfc822 ] with-string-reader ;
 
 : check-day-name ( str -- )
     [ day-abbreviations3 member? ] [ day-names member? ] bi or
     check-timestamp drop ;
 
-: (cookie-string>timestamp-1) ( -- timestamp )
+: read-cookie-string-1 ( -- timestamp )
     "," read-token check-day-name
     read1 CHAR: \s assert=
     "-" read-token checked-number
@@ -125,9 +126,9 @@ CONSTANT: rfc822-named-zones H{
     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 
 : cookie-string>timestamp-1 ( str -- timestamp )
-    [ (cookie-string>timestamp-1) ] with-string-reader ;
+    [ read-cookie-string-1 ] with-string-reader ;
 
-: (cookie-string>timestamp-2) ( -- timestamp )
+: read-cookie-string-2 ( -- timestamp )
     read-sp check-day-name
     read-sp month-abbreviations index 1 + check-timestamp
     read-sp checked-number
@@ -136,35 +137,21 @@ CONSTANT: rfc822-named-zones H{
     " " read-until drop parse-rfc822-gmt-offset <timestamp> ;
 
 : cookie-string>timestamp-2 ( str -- timestamp )
-    [ (cookie-string>timestamp-2) ] with-string-reader ;
-
-MACRO: attempt-all-quots ( quots -- quot )
-    dup length 1 = [ first ] [
-        unclip swap
-        [ nip attempt-all-quots ] curry
-        [ recover ] 2curry
-    ] if ;
+    [ read-cookie-string-2 ] with-string-reader ;
 
 : cookie-string>timestamp ( str -- timestamp )
     {
-        [ cookie-string>timestamp-1 ]
-        [ cookie-string>timestamp-2 ]
-        [ rfc822>timestamp ]
-    } attempt-all-quots ;
-
-: (ymdhms>timestamp) ( -- timestamp )
-    read-ymd " " expect read-hms instant <timestamp> ;
+        [ [ cookie-string>timestamp-1 ] [ 2drop f ] recover ]
+        [ [ cookie-string>timestamp-2 ] [ 2drop f ] recover ]
+        [ [ rfc822>timestamp ] [ 2drop f ] recover ]
+    } 1|| ;
 
 : ymdhms>timestamp ( str -- timestamp )
-    [ (ymdhms>timestamp) ] with-string-reader ;
-
-: (ymd>timestamp) ( -- timestamp )
-    read-ymd <date-gmt> ;
+    [ read-ymd " " expect read-hms instant <timestamp> ] with-string-reader ;
 
 : ymd>timestamp ( str -- timestamp )
-    [ (ymd>timestamp) ] with-string-reader ;
+    [ read-ymd <date-gmt> ] with-string-reader ;
 
-! Duration parsing
 : hhmm>duration ( hhmm -- duration )
     [ instant read-00 >>hour read-00 >>minute ] with-string-reader ;
 

diff --git a/extra/dbf/dbf.factor b/extra/dbf/dbf.factor
index 62daadedc8f87b28692c8ed5bd69c8af4d47ba41..e7f3e60d314d85032d0cbf9f83106e04b673b1aa 100644 (file)
--- a/extra/dbf/dbf.factor
+++ b/extra/dbf/dbf.factor
@@ -203,7 +203,7 @@ TUPLE: dbf file-header field-headers records ;
 
 : parse-date ( byte-array -- date/f )
     dup [ " \0" member? ] all? [ drop f ] [
-        binary [ (ymd>timestamp) ] with-byte-reader
+        binary [ read-ymd <date-gmt> ] with-byte-reader
     ] if ;
 
 : parse-float ( byte-array -- n )

diff --git a/extra/git/git.factor b/extra/git/git.factor
index 90828b71945ea06f7790d2cd3eeed5897e50bda3..8ec6ae9b5eea08760d7a8a1516f64d708959e4ce 100644 (file)
--- a/extra/git/git.factor
+++ b/extra/git/git.factor
@@ -136,7 +136,7 @@ CONSTRUCTOR: <tree> tree ( -- obj ) ;
     last2
     [ string>number unix-time>timestamp ]
     [ gmt-offset>duration [ time+ ] [ >>gmt-offset ] bi ] bi*
-    timestamp>git-time ;
+    timestamp>git-string ;
 
 : commit. ( commit -- )
     {