-import Data.Convertible
-import Data.Fixed
-import Data.Time
-import Data.Typeable
-
-
--- This data type is /partially ordered/ so we can't make it an
--- instance of Ord (e.g. "2010" and "2010-01" can't be compared).
-data W3CDateTime
- = W3CDateTime {
- w3cYear :: !Integer
- , w3cMonth :: !(Maybe Int)
- , w3cDay :: !(Maybe Int)
- , w3cHour :: !(Maybe Int)
- , w3cMinute :: !(Maybe Int)
- , w3cSecond :: !(Maybe Pico)
- , w3cTimeZone :: !(Maybe TimeZone)
- }
- deriving (Show, Eq, Typeable)
-
-instance Convertible Day W3CDateTime where
- safeConvert day
- = case toGregorian day of
- (y, m, d) -> return W3CDateTime {
- w3cYear = y
- , w3cMonth = Just m
- , w3cDay = Just d
- , w3cHour = Nothing
- , w3cMinute = Nothing
- , w3cSecond = Nothing
- , w3cTimeZone = Nothing
- }
-
-fetch :: (Show a, Typeable a, Typeable b) =>
- String
- -> (a -> Maybe b)
- -> a
- -> ConvertResult b
-fetch name f a
- = case f a of
- Nothing -> convError ("No " ++ name ++ " information in the given value") a
- Just b -> return b
-
-instance Convertible W3CDateTime Day where
- safeConvert w3c
- = do let y = w3cYear w3c
- m <- fetch "month" w3cMonth w3c
- d <- fetch "day" w3cDay w3c
- return (fromGregorian y m d)
-
-instance Convertible UTCTime W3CDateTime where
- safeConvert u
- = let (y, m, d) = toGregorian (utctDay u)
- hms = timeToTimeOfDay (utctDayTime u)
- in
- return W3CDateTime {
- w3cYear = y
- , w3cMonth = Just m
- , w3cDay = Just d
- , w3cHour = Just (todHour hms)
- , w3cMinute = Just (todMin hms)
- , w3cSecond = Just (todSec hms)
- , w3cTimeZone = Just utc
- }
-
-instance Convertible W3CDateTime UTCTime where
- safeConvert w3c
- = do day <- safeConvert w3c
- tod <- do h <- fetch "hour" w3cHour w3c
- m <- fetch "minute" w3cMinute w3c
- s <- fetch "second" w3cSecond w3c
- case makeTimeOfDayValid h m s of
- Just tod -> return tod
- Nothing -> convError "Invalid time of day" w3c
- tz <- fetch "timezone" w3cTimeZone w3c
- let lt = LocalTime day tod
- return (localTimeToUTC tz lt)