+module Data.Time.W3CDateTime.Types
+ ( W3CDateTime(..)
+ )
+ where
+
+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)