module Text.XML.XSD.DateTime
( DateTime(..)
, isoEither
, isoEither'
, fold
, pUTCTime
, pLocalTime
, dateTime
, dateTime'
, isZoned
, isUnzoned
, fromZonedTime
, toUTCTime
, fromUTCTime
, toLocalTime
, fromLocalTime
, utcTime'
, utcTime
, localTime'
, localTime
) where
import Prelude(Show(..), Read(..), Eq(..), Ord(..), Num(..), Int, Integer, String, (&&), (||), read, fromIntegral, realToFrac)
import Control.Applicative (pure, (<$>), (*>), (<|>))
import Control.Monad (Monad(..), when)
import Control.Lens(Iso', Prism', _Left, _Right, iso, prism', from, isn't, (#), (^?))
import Data.Attoparsec.Text(Parser, char, digit, parseOnly, endOfInput, takeWhile)
import Data.Bool(Bool(..))
import Data.Char (isDigit, ord)
import Data.Either(Either(..), either)
import Data.Fixed (Pico, showFixed)
import Data.Function((.), id, ($), const)
import Data.List((++))
import Data.Maybe (Maybe(..), maybeToList, maybe)
import Data.Monoid ((<>))
import Data.Text(Text, pack, unpack, length, head)
import Data.Text.Lazy as TL(toStrict)
import Data.Text.Lazy.Builder(Builder, toLazyText, fromString)
import Data.Text.Lazy.Builder.Int (decimal)
import qualified Data.Text.Read as TR(decimal)
import Data.Time
import Data.Time.Calendar.MonthDay (monthLength)
data DateTime =
DtZoned UTCTime
| DtUnzoned LocalTime
deriving Eq
mkDateTime
:: Integer
-> Int
-> Int
-> Int
-> Int
-> Pico
-> Maybe Pico
-> DateTime
mkDateTime y m d hh mm ss mz =
case mz of
Just z -> DtZoned $ addUTCTime (negate $ realToFrac z) uTime
Nothing -> DtUnzoned lTime
where
day = addDays (if hh == 24 then 1 else 0) (fromGregorian y m d)
tod = TimeOfDay (if hh == 24 then 0 else hh) mm ss
lTime = LocalTime day tod
uTime = UTCTime day (timeOfDayToTime tod)
instance Show DateTime where
show = unpack . (dateTime #)
instance Read DateTime where
readList s = [(maybeToList (pack s ^? dateTime), [])]
isoEither ::
Iso'
(Either UTCTime LocalTime)
DateTime
isoEither =
iso (either DtZoned DtUnzoned) (\t -> case t of DtZoned e -> Left e
DtUnzoned q -> Right q)
isoEither' ::
Iso'
(Either LocalTime UTCTime)
DateTime
isoEither' =
iso (either DtUnzoned DtZoned) (\t -> case t of DtUnzoned q -> Left q
DtZoned e -> Right e)
fold ::
(LocalTime -> a)
-> (UTCTime -> a)
-> DateTime
-> a
fold z _ (DtUnzoned q) =
z q
fold _ z (DtZoned e) =
z e
pUTCTime ::
Prism' DateTime UTCTime
pUTCTime =
from isoEither . _Left
pLocalTime ::
Prism' DateTime LocalTime
pLocalTime =
from isoEither . _Right
dateTime ::
Prism' Text DateTime
dateTime =
let buildUInt2 ::
Int
-> Builder
buildUInt2 x =
(if x < 10 then ("0" <>) else id) $ decimal x
buildInt4 ::
Integer
-> Builder
buildInt4 year =
let absYear = abs year
k x = if absYear < x then ("0" <>) else id
in k 1000 . k 100 . k 10 $ decimal year
toText ::
DateTime
-> Text
toText =
toStrict . toLazyText . dtBuilder
where
dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z"
dtBuilder (DtUnzoned lTime) = ltBuilder lTime
ltBuilder (LocalTime day (TimeOfDay hh mm sss)) =
let (y, m, d) = toGregorian day
in buildInt4 y
<> "-"
<> buildUInt2 m
<> "-"
<> buildUInt2 d
<> "T"
<> buildUInt2 hh
<> ":"
<> buildUInt2 mm
<> ":"
<> buildSeconds sss
in prism' toText (either (const Nothing) Just . dateTime')
dateTime' ::
Text
-> Either String DateTime
dateTime' =
parseOnly (parseDateTime <|> fail "bad date time")
buildSeconds ::
Pico
-> Builder
buildSeconds secs =
(if secs < 10 then ("0" <>) else id)
$ fromString (showFixed True secs)
fromZonedTime :: ZonedTime -> DateTime
fromZonedTime = fromUTCTime . zonedTimeToUTC
isZoned ::
DateTime
-> Bool
isZoned =
isn't pLocalTime
isUnzoned ::
DateTime
-> Bool
isUnzoned =
isn't pUTCTime
toUTCTime ::
DateTime
-> Maybe UTCTime
toUTCTime =
(^? pUTCTime)
fromUTCTime ::
UTCTime
-> DateTime
fromUTCTime =
(pUTCTime #)
toLocalTime ::
DateTime
-> Maybe LocalTime
toLocalTime =
(^? pLocalTime)
fromLocalTime ::
LocalTime
-> DateTime
fromLocalTime =
(pLocalTime #)
utcTime' ::
Text
-> Either String UTCTime
utcTime' txt =
dateTime' txt >>= maybe (Left err) Right . toUTCTime
where
err = "input time is non-timezoned"
utcTime ::
Text
-> Maybe UTCTime
utcTime txt =
txt ^? dateTime >>= toUTCTime
localTime' ::
Text
-> Either String LocalTime
localTime' txt =
dateTime' txt >>= maybe (Left err) Right . toLocalTime
where
err = "input time is non-timezoned"
localTime ::
Text
-> Maybe LocalTime
localTime txt =
txt ^? dateTime >>= toLocalTime
parseDateTime ::
Parser DateTime
parseDateTime =
do yy <- yearParser
_ <- char '-'
mm <- p2imax 12
_ <- char '-'
dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm)
_ <- char 'T'
hhh <- p2imax 24
_ <- char ':'
mmm <- p2imax 59
_ <- char ':'
sss <- secondParser
when (hhh == 24 && (mmm /= 0 || sss /= 0))
$ fail "invalid time, past 24:00:00"
o <- parseOffset
return $ mkDateTime yy mm dd hhh mmm sss o
parseOffset ::
Parser (Maybe Pico)
parseOffset =
(endOfInput *> pure Nothing)
<|>
(char 'Z' *> pure (Just 0))
<|>
(do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (1))
hh <- fromIntegral <$> p2imax 14
_ <- char ':'
mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59)
return . Just $ sign * (hh * 3600 + mm * 60))
yearParser ::
Parser Integer
yearParser =
do sign <- (char '-' *> pure (1)) <|> pure 1
ds <- takeWhile isDigit
when (length ds < 4)
$ fail "need at least four digits in year"
when (length ds > 4 && head ds == '0')
$ fail "leading zero in year"
let Right (absyear, _) = TR.decimal ds
when (absyear == 0)
$ fail "year zero disallowed"
return $ sign * absyear
secondParser ::
Parser Pico
secondParser =
do d1 <- digit
d2 <- digit
frac <- readFrac <$> (char '.' *> takeWhile isDigit)
<|> pure 0
return (read [d1, d2] + frac)
where
readFrac ds = read $ '0' : '.' : unpack ds
p2imax ::
Int
-> Parser Int
p2imax m =
do a <- digit
b <- digit
let n = 10 * val a + val b
if n > m
then fail $ "value " ++ show n ++ " exceeded maximum " ++ show m
else return n
where
val c = ord c ord '0'