, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |This module provides functions to parse and format RFC 733 date
-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM
module Data.Time.Format.RFC733
( RFC733
- , rfc733DateAndTime
)
where
import Control.Applicative
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import Data.Convertible.Base
+import Data.Default
import Data.Monoid.Unicode
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
-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
, 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
⊕ 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 |])
]