module Text.XML.XSD.DateTime(
DateTime,
dateTime',
dateTime,
toZonedTime,
fromZonedTime,
zonedTime',
zonedTime,
toUTCTime,
fromUTCTime,
utcTime',
utcTime
) where
import Text.ParserCombinators.Parsec
import Data.Char
import Data.Ord
import Data.Maybe
import Data.Time
import Data.Function
import Control.Monad
import Control.Arrow
data DateTime = DateTime Bool Int Int Int Int Int Int (Maybe String) Offset
dateTimeConstr :: Bool
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Maybe [Char]
-> Offset
-> DateTime
dateTimeConstr neg yy mm dd hhh mmm sss ssss tz = DateTime neg yy mm dd hhh mmm sss (fmap (filter isDigit) ssss) tz
instance Show DateTime where
show (DateTime neg yy mm dd hhh mmm sss ssss tz) =
join [if neg then "-" else [], showy yy, "-", showi mm, "-", showi dd, "T", showi hhh, ":", showi mmm, ":", showi sss, seconds ssss,show tz]
instance Read DateTime where
readList s = [(maybeToList (dateTime s), [])]
instance Eq DateTime where
(==) = (==) `on` (zonedTimeToLocalTime . toZonedTime &&& zonedTimeZone . toZonedTime)
instance Ord DateTime where
compare = comparing (zonedTimeToLocalTime . toZonedTime &&& zonedTimeZone . toZonedTime)
dateTime' :: String -> Either ParseError DateTime
dateTime' = parse parseDateTime "DateTime parser"
dateTime :: String -> Maybe DateTime
dateTime = either (const Nothing) Just . dateTime'
toZonedTime :: DateTime -> ZonedTime
toZonedTime (DateTime neg yy mm dd hhh mmm sss ssss tz) =
ZonedTime (
LocalTime (fromGregorian (fromIntegral ((if neg then negate else id) yy)) mm dd) (
TimeOfDay hhh mmm (realToFrac (read (show sss ++ seconds ssss) :: Double)))) (timeZone tz)
fromZonedTime :: ZonedTime -> DateTime
fromZonedTime (ZonedTime (LocalTime d (TimeOfDay hhh mmm sss)) (TimeZone m _ _)) =
let (yy, mm, dd) = toGregorian d
(sss1, sss2) = properFraction sss
(hz, mz) = m `quotRem` 60
in dateTimeConstr (yy < 0) (abs (fromIntegral yy)) mm dd hhh mmm sss1 (Just (trimTail (== '0') (drop 2 $ show sss2))) (Offset False (Just (hz < 0)) (Just hz) (Just mz))
zonedTime' :: String -> Either ParseError ZonedTime
zonedTime' = fmap toZonedTime . dateTime'
zonedTime :: String -> Maybe ZonedTime
zonedTime = fmap toZonedTime . dateTime
toUTCTime :: DateTime -> UTCTime
toUTCTime = uncurry localTimeToUTC . (zonedTimeZone &&& zonedTimeToLocalTime) . toZonedTime
fromUTCTime :: UTCTime -> DateTime
fromUTCTime (UTCTime d t) =
let (yy, mm, dd) = toGregorian d
TimeOfDay hhh mmm sss = timeToTimeOfDay t
(sss1, sss2) = properFraction sss
in dateTimeConstr (yy < 0) (abs (fromIntegral yy)) mm dd hhh mmm sss1 (Just (trimTail (== '0') (drop 2 $ show sss2))) (Offset True Nothing Nothing Nothing)
utcTime' :: String -> Either ParseError UTCTime
utcTime' = fmap toUTCTime . dateTime'
utcTime :: String -> Maybe UTCTime
utcTime = fmap toUTCTime . dateTime
data Offset = Offset Bool (Maybe Bool) (Maybe Int) (Maybe Int)
deriving Eq
instance Show Offset where
show (Offset False Nothing Nothing Nothing) = []
show (Offset True Nothing Nothing Nothing) = "Z"
show (Offset False (Just neg) (Just hh) (Just mm)) = join [if neg then "-" else "+", showi hh, ":", showi mm]
show _ = error "Offset invariant not met"
timeZone :: Offset -> TimeZone
timeZone (Offset False Nothing Nothing Nothing) = TimeZone 0 False "undetermined"
timeZone (Offset True Nothing Nothing Nothing) = TimeZone 0 False "UTC"
timeZone (Offset False (Just neg) (Just hh) (Just mm)) = TimeZone ((if neg then negate else id) hh * 60 + mm) False (join ["UTC", if neg then "-" else "+", showi hh, ":", showi mm])
timeZone _ = error "Offset invariant not met"
seconds :: Maybe String -> String
seconds (Just s) =
case s of
"" -> []
_ -> '.' : s
seconds Nothing = []
showi :: (Show a, Num a, Ord a) => a -> String
showi n = (if n < 10 then ('0':) else id) (show n)
showy :: (Show a, Num a, Ord a) => a -> String
showy n = let k t = if n < t then ('0':) else id
in k 1000 (k 100 (k 10 (show n)))
parseOffset :: GenParser Char st Offset
parseOffset = let e = const (Offset False Nothing Nothing Nothing) `fmap` eof
z = const (Offset True Nothing Nothing Nothing) `fmap` char 'Z'
o = do neg <- fmap (== '-') (char '+' <|> char '-')
hh <- p2imax 14
_ <- char ':'
mm <- p2imax (if hh == 14 then 0 else 59)
return (Offset False (Just neg) (Just hh) (Just mm))
in e <|> z <|> o
parseDateTime :: GenParser Char st DateTime
parseDateTime = do neg <- isJust `fmap` optionMaybe (char '-')
yy <- yearParser
_ <- char '-'
mm <- p2imax 12
_ <- char '-'
dd <- p2imax ([31, if isLeapYear (fromIntegral yy) then 29 else 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] !! (mm 1))
_ <- char 'T'
hhh <- p2imax 23
_ <- char ':'
mmm <- p2imax 59
_ <- char ':'
sss <- p2imax 59
ssss <- optionMaybe fractionalSeconds
o <- parseOffset
return (dateTimeConstr neg yy mm dd hhh mmm sss ssss o)
yearParser :: GenParser Char st Int
yearParser = do d1 <- digit
d2 <- digit
d3 <- digit
d4 <- digit
ds <- many digit
if not (null ds) && d1 == '0'
then unexpected "leading zero in year"
else return (read ([d1, d2, d3, d4] ++ ds))
fractionalSeconds :: GenParser Char st String
fractionalSeconds = do _ <- char '.'
many1 digit
p2imax :: Int -> GenParser Char st Int
p2imax m = do a <- digit
b <- digit
let n = read [a, b]
if n > m then unexpected ("value " ++ show n ++ " exceeded maximum " ++ show m) else return n
trimTail :: (a -> Bool) -> [a] -> [a]
trimTail = (reverse .) . (. reverse) . dropWhile