Data/Time/W3C/Types.hs

   1 module Data.Time.W3C.Types
   2     ( W3CDateTime(..)
   3     )
   4     where
   5
   6 import Data.Convertible
   7 import Data.Fixed
   8 import Data.Time
   9 import Data.Typeable
  10
  11
  12 -- This data type is /partially ordered/ so we can't make it an
  13 -- instance of Ord (e.g. "2010" and "2010-01" can't be compared).
  14 data W3CDateTime
  15     = W3CDateTime {
  16         w3cYear     :: !Integer
  17       , w3cMonth    :: !(Maybe Int)
  18       , w3cDay      :: !(Maybe Int)
  19       , w3cHour     :: !(Maybe Int)
  20       , w3cMinute   :: !(Maybe Int)
  21       , w3cSecond   :: !(Maybe Pico)
  22       , w3cTimeZone :: !(Maybe TimeZone)
  23       }
  24     deriving (Show, Eq, Typeable)
  25
  26 fetch :: (Show a, Typeable a, Typeable b) =>
  27          String
  28       -> (a -> Maybe b)
  29       -> a
  30       -> ConvertResult b
  31 fetch name f a
  32     = case f a of
  33         Nothing -> convError ("No " ++ name ++ " information in the given value") a
  34         Just b  -> return b
  35
  36 instance Convertible W3CDateTime W3CDateTime where
  37     safeConvert = return
  38
  39 instance Convertible Day W3CDateTime where
  40     safeConvert day
  41         = case toGregorian day of
  42             (y, m, d) -> return W3CDateTime {
  43                                        w3cYear     = y
  44                                      , w3cMonth    = Just m
  45                                      , w3cDay      = Just d
  46                                      , w3cHour     = Nothing
  47                                      , w3cMinute   = Nothing
  48                                      , w3cSecond   = Nothing
  49                                      , w3cTimeZone = Nothing
  50                                      }
  51
  52 instance Convertible W3CDateTime Day where
  53     safeConvert w3c
  54         = do let y = w3cYear w3c
  55              m <- fetch "month" w3cMonth w3c
  56              d <- fetch "day"   w3cDay   w3c
  57              return (fromGregorian y m d)
  58
  59 instance Convertible ZonedTime W3CDateTime where
  60     safeConvert zt
  61         = let lt  = zonedTimeToLocalTime zt
  62               tz  = zonedTimeZone zt
  63               ymd = localDay lt
  64               hms = localTimeOfDay lt
  65           in
  66             return W3CDateTime {
  67                          w3cYear     =       case toGregorian ymd of (y, _, _) -> y
  68                        , w3cMonth    = Just (case toGregorian ymd of (_, m, _) -> m)
  69                        , w3cDay      = Just (case toGregorian ymd of (_, _, d) -> d)
  70                        , w3cHour     = Just (todHour hms)
  71                        , w3cMinute   = Just (todMin  hms)
  72                        , w3cSecond   = Just (todSec  hms)
  73                        , w3cTimeZone = Just tz
  74                        }
  75
  76 instance Convertible W3CDateTime ZonedTime where
  77     safeConvert w3c
  78         = do day <- safeConvert w3c
  79              tod <- do h   <- fetch "hour"   w3cHour   w3c
  80                        m   <- fetch "minute" w3cMinute w3c
  81                        s   <- fetch "second" w3cSecond w3c
  82                        case makeTimeOfDayValid h m s of
  83                          Just tod -> return tod
  84                          Nothing  -> convError "Invalid time of day" w3c
  85              tz  <- fetch "timezone" w3cTimeZone w3c
  86              return ZonedTime {
  87                           zonedTimeToLocalTime = LocalTime day tod
  88                         , zonedTimeZone        = tz
  89                         }