From: PHO <pho@cielonegro.org>
Date: Thu, 11 Mar 2010 05:50:42 +0000 (+0900)
Subject: Convertible UTCTime <=> W3CDateTime
X-Git-Tag: RELEASE-0.1.0.1~14
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-w3c.git;a=commitdiff_plain;h=587fbc5efa8806c6bb0f37d177995cf73c0cc909

Convertible UTCTime <=> W3CDateTime
---

diff --git a/Data/Time/W3CDateTime.hs b/Data/Time/W3CDateTime.hs
index a0de70e..5505474 100644
--- a/Data/Time/W3CDateTime.hs
+++ b/Data/Time/W3CDateTime.hs
@@ -23,33 +23,60 @@ data W3CDateTime
       }
     deriving (Show, Eq, Typeable)
 
-empty :: W3CDateTime
-empty = W3CDateTime {
-          w3cYear     = 0
-        , w3cMonth    = Nothing
-        , w3cDay      = Nothing
-        , w3cHour     = Nothing
-        , w3cMinute   = Nothing
-        , w3cSecond   = Nothing
-        , w3cTimeZone = Nothing
-        }
-
 instance Convertible Day W3CDateTime where
     safeConvert day
         = case toGregorian day of
-            (y, m, d) -> return empty {
-                           w3cYear  = y
-                         , w3cMonth = Just m
-                         , w3cDay   = Just d
-                         }
+            (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 <- case w3cMonth w3c of
-                    Just m  -> return m
-                    Nothing -> convError "No month info" w3c
-             d <- case w3cDay w3c of
-                    Just d  -> return d
-                    Nothing -> convError "No day info" w3c
-             return $ fromGregorian y m d
\ No newline at end of file
+             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)