X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FFormat%2FHTTP.hs;h=1d2ceac68382fd08e3378258fe974f28cb385b5e;hp=7e30cbfc48138e681bdb1aec65d944a2fbea2545;hb=e8f778a;hpb=91c2402d530afff7f1fd4eee333f84cbe18d1014

diff --git a/Data/Time/Format/HTTP.hs b/Data/Time/Format/HTTP.hs
index 7e30cbf..1d2ceac 100644
--- a/Data/Time/Format/HTTP.hs
+++ b/Data/Time/Format/HTTP.hs
@@ -3,6 +3,7 @@
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 -- |This module provides functions to parse and format HTTP\/1.1 date
@@ -46,7 +47,6 @@
 -- >              | "Sep" | "Oct" | "Nov" | "Dec"
 module Data.Time.Format.HTTP
     ( HTTP
-    , httpDateAndTime
     )
     where
 import Control.Applicative
@@ -54,9 +54,10 @@ import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Convertible.Base
+import Data.Default
 import Data.Tagged
 import Data.Time
-import Data.Time.Format.Asctime
+import Data.Time.Format.C
 import Data.Time.Format.HTTP.Common
 import Data.Time.Format.RFC733
 import Data.Time.Format.RFC822
@@ -66,45 +67,43 @@ import Prelude.Unicode
 -- |The phantom type for conversions between HTTP/1.1 date and time
 -- strings and 'UTCTime'.
 --
--- >>> convertSuccess (UTCTime (ModifiedJulianDay 49662) 31777)
--- Tagged "Sun, 06 Nov 1994 08:49:37 GMT"
+-- >>> convertSuccess (Tagged (UTCTime (ModifiedJulianDay 49662) 31777) :: Tagged HTTP UTCTime)
+-- "Sun, 06 Nov 1994 08:49:37 GMT"
 data HTTP
 
-instance ConvertSuccess UTCTime (Tagged HTTP Ascii) where
+instance ConvertSuccess (Tagged HTTP UTCTime) Ascii where
     {-# INLINE convertSuccess #-}
-    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+    convertSuccess = A.fromAsciiBuilder ∘ cs
 
-instance ConvertSuccess UTCTime (Tagged HTTP AsciiBuilder) where
+instance ConvertSuccess (Tagged HTTP UTCTime) AsciiBuilder where
     {-# INLINE convertSuccess #-}
-    convertSuccess = Tagged ∘ toAsciiBuilder
+    convertSuccess = toAsciiBuilder
 
-instance ConvertAttempt (Tagged HTTP Ascii) UTCTime where
+instance ConvertAttempt Ascii (Tagged HTTP UTCTime) where
     {-# INLINE convertAttempt #-}
-    convertAttempt = parseAttempt' httpDateAndTime ∘ untag
+    convertAttempt = parseAttempt' def
 
 -- |Parse a date and time string in any of RFC 822, RFC 1123, RFC 850
 -- and ANSI C's asctime() formats.
 --
--- This function is even more permissive than what HTTP\/1.1 (RFC
--- 2616) specifies. That is, it accepts 2-digit years in RFC 822,
--- omitted separator symbols in RFC 850, omitted sec fields, and
--- non-GMT time zones. I believe this behavior will not cause a
--- problem though.
-httpDateAndTime ∷ Parser UTCTime
-httpDateAndTime
-    = choice [ zonedTimeToUTC     <$> try rfc1123DateAndTime
-             , zonedTimeToUTC     <$> try rfc733DateAndTime
-             , zonedTimeToUTC     <$> try rfc822DateAndTime
-             , localTimeToUTC utc <$> asctime
-             ]
+-- This parser is even more permissive than what HTTP\/1.1 (RFC 2616)
+-- specifies. That is, it accepts 2-digit years in RFC 822, omitted
+-- separator symbols in RFC 850, omitted sec fields, and non-GMT time
+-- zones. I believe this behavior will not cause a problem though.
+instance Default (Parser (Tagged HTTP UTCTime)) where
+    {-# INLINEABLE def #-}
+    def = Tagged
+          <$>
+          choice [ (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC1123 ZonedTime))
+                 , (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC733  ZonedTime))
+                 , (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC822  ZonedTime))
+                 , (localTimeToUTC utc ∘ untag) <$>     (def ∷ Parser (Tagged C       LocalTime))
+                 ]
 
-toAsciiBuilder ∷ UTCTime → AsciiBuilder
-toAsciiBuilder = untag' ∘ cs ∘ ut2zt
+toAsciiBuilder ∷ Tagged HTTP UTCTime → AsciiBuilder
+{-# INLINEABLE toAsciiBuilder #-}
+toAsciiBuilder = cs ∘ (ut2zt <$>) ∘ retag'
     where
-      untag' ∷ Tagged RFC1123 AsciiBuilder → AsciiBuilder
-      {-# INLINE CONLIKE untag' #-}
-      untag' = untag
-
       ut2zt ∷ UTCTime → ZonedTime
       {-# INLINE ut2zt #-}
       ut2zt = utcToZonedTime gmt
@@ -113,6 +112,10 @@ toAsciiBuilder = untag' ∘ cs ∘ ut2zt
       {-# INLINE CONLIKE gmt #-}
       gmt = TimeZone 0 False "GMT"
 
-deriveAttempts [ ([t| UTCTime |], [t| Tagged HTTP Ascii        |])
-               , ([t| UTCTime |], [t| Tagged HTTP AsciiBuilder |])
+      retag' ∷ Tagged τ α → Tagged RFC1123 α
+      {-# INLINE retag' #-}
+      retag' = retag
+
+deriveAttempts [ ([t| Tagged HTTP UTCTime |], [t| Ascii        |])
+               , ([t| Tagged HTTP UTCTime |], [t| AsciiBuilder |])
                ]