Merge branch 'data-default'

[time-http.git] / Data / Time / Format / RFC1123.hs

diff --git a/Data/Time/Format/RFC1123.hs b/Data/Time/Format/RFC1123.hs
index 1d4f28eb99c5d328d8d8dc5357d0d8a43ba19231..9f3fbd6eaf87e6b2009de7b931d06739c253e795 100644 (file)
--- a/Data/Time/Format/RFC1123.hs
+++ b/Data/Time/Format/RFC1123.hs
@@ -3,6 +3,7 @@
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 -- |This module provides functions to parse and format RFC 1123 date
@@ -18,68 +19,61 @@
 -- > year ::= 4DIGIT
 module Data.Time.Format.RFC1123
     ( RFC1123
-    , rfc1123
-    , rfc1123DateAndTime
     )
     where
 import Control.Applicative
+import Control.Applicative.Unicode
 import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Convertible.Base
+import Data.Default
 import Data.Monoid.Unicode
-import Data.Proxy
 import Data.Tagged
 import Data.Time
 import Data.Time.Calendar.WeekDate
 import Data.Time.Format.HTTP.Common
-import Data.Time.Format.RFC822.Internal
+import Data.Time.Format.RFC822
 import Prelude.Unicode
 
 -- |The phantom type for conversions between RFC 1123 date and time
 -- strings and 'ZonedTime'.
 --
--- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
--- Tagged "Sun, 06 Nov 1994 08:49:37 GMT"
+-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC1123 ZonedTime)
+-- "Sun, 06 Nov 1994 08:49:37 GMT"
 data RFC1123
 
--- |The proxy for conversions between RFC 1123 date and time strings
--- and 'ZonedTime'.
-rfc1123 ∷ Proxy RFC1123
-{-# INLINE CONLIKE rfc1123 #-}
-rfc1123 = Proxy
-
-instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where
+instance ConvertSuccess (Tagged RFC1123 ZonedTime) Ascii where
     {-# INLINE convertSuccess #-}
-    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+    convertSuccess = A.fromAsciiBuilder ∘ cs
 
-instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where
+instance ConvertSuccess (Tagged RFC1123 ZonedTime) AsciiBuilder where
     {-# INLINE convertSuccess #-}
-    convertSuccess = Tagged ∘ toAsciiBuilder
+    convertSuccess = toAsciiBuilder
 
-instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where
+instance ConvertAttempt Ascii (Tagged RFC1123 ZonedTime) where
     {-# INLINE convertAttempt #-}
-    convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag
+    convertAttempt = parseAttempt' def
 
 -- |Parse an RFC 1123 date and time string.
-rfc1123DateAndTime ∷ Parser ZonedTime
-rfc1123DateAndTime = dateTime
-
-dateTime ∷ Parser ZonedTime
-dateTime = do weekDay ← optionMaybe $
-                         do w ← shortWeekDayNameP
-                            _ ← string ", "
-                            return w
-              gregDay ← date
-              case weekDay of
-                Nothing
-                    → return ()
-                Just givenWD
-                    → assertWeekDayIsGood givenWD gregDay
-              (tod, timeZone) ← rfc822Time
-              let lt = LocalTime gregDay tod
-                  zt = ZonedTime lt timeZone
-              return zt
+instance Default (Parser (Tagged RFC1123 ZonedTime)) where
+    def = do weekDay ← optionMaybe $
+                       do w ← shortWeekDayNameP
+                          string ", " *> pure w
+             gregDay ← date
+             case weekDay of
+               Nothing
+                   → return ()
+               Just givenWD
+                   → assertWeekDayIsGood givenWD gregDay
+             tod ← def
+             tz  ← char ' ' *> def
+             let lt = LocalTime gregDay <$> tod
+                 zt = ZonedTime <$> lt ⊛ tz
+             pure $ retag' zt
+        where
+          retag' ∷ Tagged RFC822 α → Tagged τ α
+          retag' = retag
 
 date ∷ Parser Day
 date = do day   ← read2
@@ -90,10 +84,10 @@ date = do day   ← read2
           _     ← char ' '
           assertGregorianDateIsGood year month day
 
-toAsciiBuilder ∷ ZonedTime → AsciiBuilder
+toAsciiBuilder ∷ Tagged RFC1123 ZonedTime → AsciiBuilder
 toAsciiBuilder zonedTime
-    = let localTime          = zonedTimeToLocalTime zonedTime
-          timeZone           = zonedTimeZone zonedTime
+    = let localTime          = zonedTimeToLocalTime $ untag zonedTime
+          timeZone           = zonedTimeZone <$> retag' zonedTime
           (year, month, day) = toGregorian (localDay localTime)
           (_, _, week)       = toWeekDate  (localDay localTime)
           timeOfDay          = localTimeOfDay localTime
@@ -112,8 +106,11 @@ toAsciiBuilder zonedTime
         ⊕ A.toAsciiBuilder ":"
         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
         ⊕ A.toAsciiBuilder " "
-        ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
+        ⊕ cs timeZone
+    where
+      retag' ∷ Tagged τ α → Tagged RFC822 α
+      retag' = retag
 
-deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii        |])
-               , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |])
+deriveAttempts [ ([t| Tagged RFC1123 ZonedTime |], [t| Ascii        |])
+               , ([t| Tagged RFC1123 ZonedTime |], [t| AsciiBuilder |])
                ]