Rewrote RFC733

Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5

diff --git a/Data/Time/Asctime.hs b/Data/Time/Asctime.hs
index de9de39d5f3dc0eca98b8af75fad91ed76157346..f8d28ccd80091fb0424c779245aaa6627d50068a 100644 (file)
--- a/Data/Time/Asctime.hs
+++ b/Data/Time/Asctime.hs
@@ -2,6 +2,7 @@
     FlexibleInstances
   , MultiParamTypeClasses
   , OverloadedStrings
     FlexibleInstances
   , MultiParamTypeClasses
   , OverloadedStrings

+  , TemplateHaskell

   , UnicodeSyntax
   #-}
 -- |This module provides functions for ANSI C's asctime() format.
   , UnicodeSyntax
   #-}
 -- |This module provides functions for ANSI C's asctime() format.


@@ -52,18 +53,10 @@ instance ConvertSuccess LocalTime (Tagged Asctime Ascii) where
     {-# INLINE convertSuccess #-}
     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
 
     {-# INLINE convertSuccess #-}
     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
 

-instance ConvertAttempt LocalTime (Tagged Asctime Ascii) where
-    {-# INLINE convertAttempt #-}
-    convertAttempt = return ∘ cs
-

 instance ConvertSuccess LocalTime (Tagged Asctime AsciiBuilder) where
     {-# INLINE convertSuccess #-}
     convertSuccess = Tagged ∘ toAsciiBuilder
 
 instance ConvertSuccess LocalTime (Tagged Asctime AsciiBuilder) where
     {-# INLINE convertSuccess #-}
     convertSuccess = Tagged ∘ toAsciiBuilder
 

-instance ConvertAttempt LocalTime (Tagged Asctime AsciiBuilder) where
-    {-# INLINE convertAttempt #-}
-    convertAttempt = return ∘ cs
-

 instance ConvertAttempt (Tagged Asctime Ascii) LocalTime where
     {-# INLINE convertAttempt #-}
     convertAttempt = parseAttempt' asctime ∘ untag
 instance ConvertAttempt (Tagged Asctime Ascii) LocalTime where
     {-# INLINE convertAttempt #-}
     convertAttempt = parseAttempt' asctime ∘ untag


@@ -109,3 +102,7 @@ toAsciiBuilder localTime
         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
         ⊕ A.toAsciiBuilder " "
         ⊕ show4 year
         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
         ⊕ A.toAsciiBuilder " "
         ⊕ show4 year

+
+deriveAttempts [ ([t| LocalTime |], [t| Tagged Asctime Ascii        |])
+               , ([t| LocalTime |], [t| Tagged Asctime AsciiBuilder |])
+               ]

diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs
index 6234c1b50b8fb9848123ccd602a6a1814de22ffc..e6981afe31ab2eec7dac999831b5d7ec244e13dd 100644 (file)
--- a/Data/Time/RFC733.hs
+++ b/Data/Time/RFC733.hs
@@ -1,5 +1,9 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    UnicodeSyntax
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , TemplateHaskell
+  , UnicodeSyntax

   #-}
 -- |This module provides functions to parse and format RFC 733 date
 -- and time formats.
   #-}
 -- |This module provides functions to parse and format RFC 733 date
 -- and time formats.


@@ -41,31 +45,156 @@
 -- >               | "Y"                ; +12
 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
 module Data.Time.RFC733
 -- >               | "Y"                ; +12
 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
 module Data.Time.RFC733

-    ( -- * Formatting
-      toAscii
-    , toAsciiBuilder
-
-      -- * Parsing
-    , fromAscii
+    ( RFC733

     , rfc733DateAndTime
     )
     where
     , rfc733DateAndTime
     )
     where

-import Data.Ascii (Ascii)
+import Control.Applicative
+import Data.Ascii (Ascii, AsciiBuilder)

 import qualified Data.Ascii as A
 import qualified Data.Ascii as A

-import qualified Data.Attoparsec.Char8 as P
+import Data.Attoparsec.Char8
+import Data.Convertible.Base
+import Data.Monoid.Unicode
+import Data.Tagged

 import Data.Time
 import Data.Time

-import Data.Time.RFC733.Internal
+import Data.Time.Calendar.WeekDate
+import Data.Time.RFC822.Internal hiding (toAsciiBuilder)
+import Data.Time.HTTP.Common

 import Prelude.Unicode
 
 import Prelude.Unicode
 

--- |Convert a 'ZonedTime' to RFC 733 date and time string.
-toAscii ∷ ZonedTime → Ascii
-toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder
+-- FIXME: docs
+data RFC733

 
 

--- |Parse an RFC 733 date and time string. When the string can't be
--- parsed, it returns @'Left' err@.
-fromAscii ∷ Ascii → Either String ZonedTime
-fromAscii = P.parseOnly p ∘ A.toByteString
-    where
-      p = do zt ← rfc733DateAndTime
-             P.endOfInput
-             return zt
+instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+
+instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = Tagged ∘ toAsciiBuilder
+
+instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag
+
+rfc733DateAndTime ∷ Parser ZonedTime
+rfc733DateAndTime = dateTime
+
+dateTime ∷ Parser ZonedTime
+dateTime = do weekDay ← optionMaybe $
+                        do w ← longWeekDayNameP
+                               <|>
+                               shortWeekDayNameP
+                           _ ← string ", "
+                           return w
+              gregDay ← date
+              case weekDay of
+                Nothing
+                    → return ()
+                Just givenWD
+                    → assertWeekDayIsGood givenWD gregDay
+              (tod, timeZone) ← time
+              let lt = LocalTime gregDay tod
+                  zt = ZonedTime lt timeZone
+              return zt
+
+date ∷ Parser Day
+date = do day   ← read2
+          _     ← char '-' <|> char ' '
+          month ← try longMonthNameP
+                  <|>
+                  shortMonthNameP
+          _     ← char '-' <|> char ' '
+          year  ← try read4
+                  <|>
+                  (+ 1900) <$> read2
+          _     ← char ' '
+          assertGregorianDateIsGood year month day
+
+time ∷ Parser (TimeOfDay, TimeZone)
+time = do tod ← hms
+          _   ← char '-' <|> char ' '
+          tz  ← zone
+          return (tod, tz)
+
+hms ∷ Parser TimeOfDay
+hms = do hour   ← read2
+         _      ← optional (char ':')
+         minute ← read2
+         second ← option 0 $
+                  do _ ← optional (char ':')
+                     read2
+         assertTimeOfDayIsGood hour minute second
+
+zone ∷ Parser TimeZone
+zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
+              , char 'N'
+                *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
+                          , return (TimeZone (1 * 60) False "N")
+                          ]
+              , char 'A'
+                *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
+                          , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
+                          , return (TimeZone ((-1) * 60) False "A")
+                          ]
+              , char 'E'
+                *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
+                          , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
+                          ]
+              , char 'C'
+                *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
+                          , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
+                          ]
+              , char 'M'
+                *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
+                          , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
+                          , return (TimeZone ((-12) * 60) False "M")
+                          ]
+              , char 'P'
+                *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
+                          , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
+                          ]
+              , char 'Y'
+                *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
+                          , string "DT" *> return (TimeZone ((-8) * 60) True  "YDT")
+                          , return (TimeZone ( 12  * 60) False "Y")
+                          ]
+              , char 'H'
+                *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
+                          , string "DT" *> return (TimeZone (( -9) * 60) True  "HDT")
+                          ]
+              , char 'B'
+                *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
+                          , string "DT" *> return (TimeZone ((-10) * 60) True  "BDT")
+                          ]
+              , char 'Z' *> return (TimeZone 0 False "Z")
+              , read4digitsTZ
+              ]
+
+toAsciiBuilder ∷ ZonedTime → AsciiBuilder
+toAsciiBuilder zonedTime
+    = let localTime          = zonedTimeToLocalTime zonedTime
+          timeZone           = zonedTimeZone zonedTime
+          (year, month, day) = toGregorian (localDay localTime)
+          (_, _, week)       = toWeekDate  (localDay localTime)
+          timeOfDay          = localTimeOfDay localTime
+      in
+        longWeekDayName week
+        ⊕ A.toAsciiBuilder ", "
+        ⊕ show2 day
+        ⊕ A.toAsciiBuilder "-"
+        ⊕ shortMonthName month
+        ⊕ A.toAsciiBuilder "-"
+        ⊕ show4 year
+        ⊕ A.toAsciiBuilder " "
+        ⊕ show2 (todHour timeOfDay)
+        ⊕ A.toAsciiBuilder ":"
+        ⊕ show2 (todMin timeOfDay)
+        ⊕ A.toAsciiBuilder ":"
+        ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
+        ⊕ A.toAsciiBuilder " "
+        ⊕ showRFC822TimeZone timeZone
+
+deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii        |])
+               , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])
+               ]

diff --git a/Data/Time/RFC733/Internal.hs b/Data/Time/RFC733/Internal.hs
deleted file mode 100644 (file)
index 4037918..0000000
--- a/Data/Time/RFC733/Internal.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE
-    OverloadedStrings
-  , UnicodeSyntax
-  #-}
--- |Internal functions for "Data.Time.RFC733".
-module Data.Time.RFC733.Internal
-    ( rfc733DateAndTime
-    , toAsciiBuilder
-    )
-    where
-import Data.Ascii (AsciiBuilder)
-import qualified Data.Ascii as A
-import Control.Applicative
-import Data.Attoparsec.Char8
-import Data.Monoid.Unicode
-import Data.Time
-import Data.Time.Calendar.WeekDate
-import Data.Time.HTTP.Common
-import Data.Time.RFC822.Internal hiding (toAsciiBuilder)
-
--- |Parse RFC 733 date and time strings.
-rfc733DateAndTime ∷ Parser ZonedTime
-rfc733DateAndTime = dateTime
-
-dateTime ∷ Parser ZonedTime
-dateTime = do weekDay ← optionMaybe $
-                        do w ← longWeekDayNameP
-                               <|>
-                               shortWeekDayNameP
-                           _ ← string ", "
-                           return w
-              gregDay ← date
-              case weekDay of
-                Nothing
-                    → return ()
-                Just givenWD
-                    → assertWeekDayIsGood givenWD gregDay
-              (tod, timeZone) ← time
-              let lt = LocalTime gregDay tod
-                  zt = ZonedTime lt timeZone
-              return zt
-
-date ∷ Parser Day
-date = do day   ← read2
-          _     ← char '-' <|> char ' '
-          month ← try longMonthNameP
-                  <|>
-                  shortMonthNameP
-          _     ← char '-' <|> char ' '
-          year  ← try read4
-                  <|>
-                  (+ 1900) <$> read2
-          _     ← char ' '
-          assertGregorianDateIsGood year month day
-
-time ∷ Parser (TimeOfDay, TimeZone)
-time = do tod ← hms
-          _   ← char '-' <|> char ' '
-          tz  ← zone
-          return (tod, tz)
-
-hms ∷ Parser TimeOfDay
-hms = do hour   ← read2
-         _      ← optional (char ':')
-         minute ← read2
-         second ← option 0 $
-                  do _ ← optional (char ':')
-                     read2
-         assertTimeOfDayIsGood hour minute second
-
-zone ∷ Parser TimeZone
-zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
-              , char 'N'
-                *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
-                          , return (TimeZone (1 * 60) False "N")
-                          ]
-              , char 'A'
-                *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
-                          , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
-                          , return (TimeZone ((-1) * 60) False "A")
-                          ]
-              , char 'E'
-                *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
-                          , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
-                          ]
-              , char 'C'
-                *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
-                          , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
-                          ]
-              , char 'M'
-                *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
-                          , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
-                          , return (TimeZone ((-12) * 60) False "M")
-                          ]
-              , char 'P'
-                *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
-                          , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
-                          ]
-              , char 'Y'
-                *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
-                          , string "DT" *> return (TimeZone ((-8) * 60) True  "YDT")
-                          , return (TimeZone ( 12  * 60) False "Y")
-                          ]
-              , char 'H'
-                *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
-                          , string "DT" *> return (TimeZone (( -9) * 60) True  "HDT")
-                          ]
-              , char 'B'
-                *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
-                          , string "DT" *> return (TimeZone ((-10) * 60) True  "BDT")
-                          ]
-              , char 'Z' *> return (TimeZone 0 False "Z")
-              , read4digitsTZ
-              ]
-
--- |Convert a 'ZonedTime' to RFC 733 date and time string.
-toAsciiBuilder ∷ ZonedTime → AsciiBuilder
-toAsciiBuilder zonedTime
-    = let localTime          = zonedTimeToLocalTime zonedTime
-          timeZone           = zonedTimeZone zonedTime
-          (year, month, day) = toGregorian (localDay localTime)
-          (_, _, week)       = toWeekDate  (localDay localTime)
-          timeOfDay          = localTimeOfDay localTime
-      in
-        longWeekDayName week
-        ⊕ A.toAsciiBuilder ", "
-        ⊕ show2 day
-        ⊕ A.toAsciiBuilder "-"
-        ⊕ shortMonthName month
-        ⊕ A.toAsciiBuilder "-"
-        ⊕ show4 year
-        ⊕ A.toAsciiBuilder " "
-        ⊕ show2 (todHour timeOfDay)
-        ⊕ A.toAsciiBuilder ":"
-        ⊕ show2 (todMin timeOfDay)
-        ⊕ A.toAsciiBuilder ":"
-        ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
-        ⊕ A.toAsciiBuilder " "
-        ⊕ showRFC822TimeZone timeZone

diff --git a/Test/Time/HTTP.hs b/Test/Time/HTTP.hs
index 2f7225e15eaf2fe1e35d8eff196c0579c3917c32..7ef3210af7d0a49390bf1859613bf76be50ad443 100644 (file)
--- a/Test/Time/HTTP.hs
+++ b/Test/Time/HTTP.hs
@@ -6,12 +6,13 @@ module Main (main) where
 import Control.Applicative
 import Control.Applicative.Unicode
 import Data.Ascii (Ascii)
 import Control.Applicative
 import Control.Applicative.Unicode
 import Data.Ascii (Ascii)

+import Data.Attempt hiding (Failure, Success)

 import Data.Convertible.Base
 import Data.Tagged
 import Data.Time
 import Data.Time.Asctime
 import qualified Data.Time.HTTP    as HTTP
 import Data.Convertible.Base
 import Data.Tagged
 import Data.Time
 import Data.Time.Asctime
 import qualified Data.Time.HTTP    as HTTP

-import qualified Data.Time.RFC733  as RFC733
+import Data.Time.RFC733

 import qualified Data.Time.RFC1123 as RFC1123
 import System.Exit
 import Prelude.Unicode
 import qualified Data.Time.RFC1123 as RFC1123
 import System.Exit
 import Prelude.Unicode


@@ -63,30 +64,28 @@ instance Arbitrary UTCTime where
 
 tests ∷ [Property]
 tests = [ -- Asctime
 
 tests ∷ [Property]
 tests = [ -- Asctime

-          property ( convertUnsafe ( Tagged "Sun Nov  6 08:49:37 1994"
-                                     ∷ Tagged Asctime Ascii
-                                   )
-                     ≡ referenceLocalTime
+          property ( fromAttempt (ca (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged Asctime Ascii))
+                     ≡ Just referenceLocalTime

                    )
 
                    )
 

-        , property ( ( Tagged "Sun Nov  6 08:49:37 1994"
-                       ∷ Tagged Asctime Ascii
-                     )
+        , property ( (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged Asctime Ascii)

                      ≡ cs referenceLocalTime
                    )
 
                      ≡ cs referenceLocalTime
                    )
 

-        , property $ \lt → lt ≡ convertUnsafe ( cs (lt ∷ LocalTime)
-                                                ∷ Tagged Asctime Ascii
-                                              )
+        , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime)
+                                                        ∷ Tagged Asctime Ascii))

 
           -- RFC733
 
           -- RFC733

-        , property ( RFC733.fromAscii "Sunday, 06-Nov-94 08:49:37 GMT"
-                     ≡ Right referenceZonedTime )
+        , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
+                     ≡ Just referenceZonedTime
+                   )

 
 

-        , property ( "Sunday, 06-Nov-1994 08:49:37 GMT"
-                     ≡ RFC733.toAscii referenceZonedTime )
+        , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
+                     ≡ cs referenceZonedTime
+                   )

 
 

-        , property $ \zt → Right zt ≡ RFC733.fromAscii (RFC733.toAscii zt)
+        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
+                                                        ∷ Tagged RFC733 Ascii))

 
           -- RFC1123
         , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT"
 
           -- RFC1123
         , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT"


@@ -100,7 +99,7 @@ tests = [ -- Asctime
           -- HTTP
         , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii           ut )
         , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2lt ut) ∷ Tagged Asctime Ascii))
           -- HTTP
         , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii           ut )
         , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2lt ut) ∷ Tagged Asctime Ascii))

-        , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC733.toAscii  (ut2zt ut))
+        , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2zt ut) ∷ Tagged RFC733  Ascii))

         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut))
         ]
     where
         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut))
         ]
     where

diff --git a/time-http.cabal b/time-http.cabal
index b6bc9aaec82101340626abda585af90ccecdd6fa..bd7072c70072436383754ecfb92b27f237d21060 100644 (file)
--- a/time-http.cabal
+++ b/time-http.cabal
@@ -36,7 +36,6 @@ Library
         Data.Time.HTTP.Common
         Data.Time.HTTP.Internal
         Data.Time.RFC1123.Internal
         Data.Time.HTTP.Common
         Data.Time.HTTP.Internal
         Data.Time.RFC1123.Internal

-        Data.Time.RFC733.Internal

         Data.Time.RFC822.Internal
 
     Build-depends:
         Data.Time.RFC822.Internal
 
     Build-depends:


@@ -48,7 +47,7 @@ Library
         blaze-builder        == 0.3.*,
         blaze-textual        == 0.2.*,
         bytestring           == 0.9.*,
         blaze-builder        == 0.3.*,
         blaze-textual        == 0.2.*,
         bytestring           == 0.9.*,

-        convertible-text     == 0.3.*,
+        convertible-text     == 0.4.*,

         tagged               == 0.2.*,
         time                 == 1.2.*
 
         tagged               == 0.2.*,
         time                 == 1.2.*
 


@@ -72,7 +71,7 @@ Test-Suite test-time-http
         blaze-builder        == 0.3.*,
         blaze-textual        == 0.2.*,
         bytestring           == 0.9.*,
         blaze-builder        == 0.3.*,
         blaze-textual        == 0.2.*,
         bytestring           == 0.9.*,

-        convertible-text     == 0.3.*,
+        convertible-text     == 0.4.*,

         tagged               == 0.2.*,
         time                 == 1.2.*
     GHC-Options:
         tagged               == 0.2.*,
         time                 == 1.2.*
     GHC-Options: