Renamed package name: w3cdatetime -> time-w3c

[time-w3c.git] / Data / Time / W3CDateTime / Types.hs

diff --git a/Data/Time/W3CDateTime/Types.hs b/Data/Time/W3CDateTime/Types.hs
new file mode 100644 (file)
index 0000000..b41023c
--- /dev/null
+++ b/Data/Time/W3CDateTime/Types.hs
@@ -0,0 +1,82 @@
+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)