Use data-default to provide fafault parsers; remove proxies.

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

diff --git a/Data/Time/Format/RFC733.hs b/Data/Time/Format/RFC733.hs
index 58dec8dfde636aed9b79bd24eb0335df331c0ab3..3b66c88742e5a5344a1f29b66e3e2d1d406466bd 100644 (file)
--- a/Data/Time/Format/RFC733.hs
+++ b/Data/Time/Format/RFC733.hs
@@ -3,6 +3,7 @@
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 -- |This module provides functions to parse and format RFC 733 date
@@ -46,8 +47,6 @@
 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
 module Data.Time.Format.RFC733
     ( RFC733
-    , rfc733
-    , rfc733DateAndTime
     )
     where
 import Control.Applicative
@@ -55,61 +54,51 @@ 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 733 date and time
 -- strings and 'ZonedTime'.
 --
--- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
--- Tagged "Sunday, 06-Nov-1994 08:49:37 GMT"
+-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC733 ZonedTime)
+-- "Sunday, 06-Nov-1994 08:49:37 GMT"
 data RFC733
 
--- |The proxy for conversions between RFC 733 date and time strings
--- and 'ZonedTime'.
-rfc733 ∷ Proxy RFC733
-{-# INLINE CONLIKE rfc733 #-}
-rfc733 = Proxy
-
-instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where
+instance ConvertSuccess (Tagged RFC733 ZonedTime) Ascii where
     {-# INLINE convertSuccess #-}
-    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+    convertSuccess = A.fromAsciiBuilder ∘ cs
 
-instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where
+instance ConvertSuccess (Tagged RFC733 ZonedTime) AsciiBuilder where
     {-# INLINE convertSuccess #-}
-    convertSuccess = Tagged ∘ toAsciiBuilder
+    convertSuccess = toAsciiBuilder
 
-instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where
+instance ConvertAttempt Ascii (Tagged RFC733 ZonedTime) where
     {-# INLINE convertAttempt #-}
-    convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag
+    convertAttempt = parseAttempt' def
 
 -- |Parse an RFC 733 date and time string.
-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
+instance Default (Parser (Tagged RFC733 ZonedTime)) where
+    def = do weekDay ← optionMaybe $
+                       do w ← longWeekDayNameP
+                              <|>
+                              shortWeekDayNameP
+                          string ", " *> pure 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
+             pure $ Tagged zt
 
 date ∷ Parser Day
 date = do day   ← read2
@@ -184,10 +173,10 @@ zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
               , read4digitsTZ
               ]
 
-toAsciiBuilder ∷ ZonedTime → AsciiBuilder
+toAsciiBuilder ∷ Tagged RFC733 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
@@ -206,8 +195,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 RFC733 Ascii        |])
-               , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])
+deriveAttempts [ ([t| Tagged RFC733 ZonedTime |], [t| Ascii        |])
+               , ([t| Tagged RFC733 ZonedTime |], [t| AsciiBuilder |])
                ]