xsd-0.5.0.1: src/Text/XML/XSD/DateTime.hs
{-# LANGUAGE OverloadedStrings #-}
-- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>
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)
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Test.QuickCheck.Instances ()
-- >>> let mkLocal :: Integer -> Int -> Int -> Int -> Int -> Pico -> LocalTime; mkLocal y m d hh mm ss = LocalTime (fromGregorian y m d) (TimeOfDay hh mm ss)
-- >>> let mkUTC :: Integer -> Int -> Int -> Int -> Int -> Pico -> UTCTime; mkUTC y m d hh mm ss = localTimeToUTC utc (mkLocal y m d hh mm ss)
-- >>> let mkZoned :: Integer -> Int -> Int -> Int -> Int -> Pico -> Int -> Int -> ZonedTime; mkZoned y m d hh mm ss zh zm = ZonedTime (mkLocal y m d hh mm ss) (TimeZone offset False "") where offset = signum zh * (abs zh * 60 + zm)
-- | XSD @dateTime@ data structure
-- <http://www.w3.org/TR/xmlschema-2/#dateTime>. Briefly, a @dateTime@
-- uses the Gregorian calendar and may or may not have an associated
-- timezone. If it has a timezone, then the canonical representation
-- of that date time is in UTC.
--
-- Note, it is not possible to establish a total order on @dateTime@
-- since non-timezoned are considered to belong to some unspecified
-- timezone.
data DateTime =
DtZoned UTCTime
| DtUnzoned LocalTime
deriving (Eq, Ord)
-- | Internal helper that creates a date time. Note, if the given hour
-- is 24 then the minutes and seconds are assumed to be 0.
mkDateTime
:: Integer -- ^ Year
-> Int -- ^ Month
-> Int -- ^ Day
-> Int -- ^ Hours
-> Int -- ^ Minutes
-> Pico -- ^ Seconds
-> Maybe Pico -- ^ Time zone offset
-> 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), [])]
-- | The isomorphism between a @DateTime@ and @Either UTCTime LocalTime@
isoEither ::
Iso'
(Either UTCTime LocalTime)
DateTime
isoEither =
iso (either DtZoned DtUnzoned) (\t -> case t of DtZoned e -> Left e
DtUnzoned q -> Right q)
-- | The isomorphism between a @DateTime@ and @Either LocalTime UTCTime@
isoEither' ::
Iso'
(Either LocalTime UTCTime)
DateTime
isoEither' =
iso (either DtUnzoned DtZoned) (\t -> case t of DtUnzoned q -> Left q
DtZoned e -> Right e)
-- | Reduction on a @DateTime@.
fold ::
(LocalTime -> a)
-> (UTCTime -> a)
-> DateTime
-> a
fold z _ (DtUnzoned q) =
z q
fold _ z (DtZoned e) =
z e
-- | A prism that views the @UTCTime@ component of a @DateTime@.
pUTCTime ::
Prism' DateTime UTCTime
pUTCTime =
from isoEither . _Left
-- | A prism that views the @LocalTime@ component of a @DateTime@.
pLocalTime ::
Prism' DateTime LocalTime
pLocalTime =
from isoEither . _Right
-- | A prism that parses the string into a @DateTime@ and converts the
-- @DateTime@ into a string.
--
-- prop> Just (DtZoned t) == (dateTime # fromUTCTime t) ^? dateTime
--
-- prop> Just (DtUnzoned t) == (dateTime # fromLocalTime t) ^? dateTime
--
-- >>> "2009-10-10T03:10:10-05:00" ^? dateTime
-- Just 2009-10-10T08:10:10Z
--
-- >>> "2119-10-10T03:10:10.4-13:26" ^? dateTime
-- Just 2119-10-10T16:36:10.4Z
--
-- >>> "0009-10-10T03:10:10.783952+14:00" ^? dateTime
-- Just 0009-10-09T13:10:10.783952Z
--
-- >>> "2009-10-10T03:10:10Z" ^? dateTime
-- Just 2009-10-10T03:10:10Z
--
-- >>> "-2009-05-10T21:08:59+05:00" ^? dateTime
-- Just -2009-05-10T16:08:59Z
--
-- >>> "-19399-12-31T13:10:10-14:00" ^? dateTime
-- Just -19398-01-01T03:10:10Z
--
-- >>> "2009-12-31T13:10:10" ^? dateTime
-- Just 2009-12-31T13:10:10
--
-- >>> "2012-10-15T24:00:00" ^? dateTime
-- Just 2012-10-16T00:00:00
--
-- >>> "2002-10-10T12:00:00+05:00" ^? dateTime
-- Just 2002-10-10T07:00:00Z
--
-- >>> "2002-10-10T00:00:00+05:00" ^? dateTime
-- Just 2002-10-09T19:00:00Z
--
-- >>> "-0001-10-10T00:00:00" ^? dateTime
-- Just 000-1-10-10T00:00:00
--
-- >>> "0001-10-10T00:00:00" ^? dateTime
-- Just 0001-10-10T00:00:00
--
-- >>> "2009-10-10T03:10:10-05" ^? dateTime
-- Nothing
--
-- >>> "2009-10-10T03:10:10+14:50" ^? dateTime
-- Nothing
--
-- >>> "2009-10-10T03:10:1" ^? dateTime
-- Nothing
--
-- >>> "2009-10-10T03:1:10" ^? dateTime
-- Nothing
--
-- >>> "2009-10-10T0:10:10" ^? dateTime
-- Nothing
--
-- >>> "2009-10-1T10:10:10" ^? dateTime
-- Nothing
--
-- >>> "2009-1-10T10:10:10" ^? dateTime
-- Nothing
--
-- >>> "209-10-10T03:10:10" ^? dateTime
-- Nothing
--
-- >>> "2009-10-10T24:10:10" ^? dateTime
-- Nothing
--
-- >>> "0000-01-01T00:00:00" ^? dateTime
-- Nothing
--
-- >>> "2009-13-01T00:00:00" ^? dateTime
-- Nothing
--
-- >>> "+2009-10-01T04:20:40" ^? dateTime
-- Nothing
--
-- >>> "002009-10-01T04:20:40" ^? dateTime
-- Nothing
--
-- >>> dateTime # fromUTCTime (mkUTC 2119 10 10 16 36 10.4)
-- "2119-10-10T16:36:10.4Z"
--
-- >>> dateTime # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0)
-- "2010-04-07T11:47:20.001Z"
--
-- >>> dateTime # fromLocalTime (mkLocal 13 2 4 20 20 20)
-- "0013-02-04T20:20:20"
--
-- >>> (dateTime #) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? dateTime) -- issue 2
-- Just "2010-04-07T11:47:20.001Z"
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')
-- | Parses the string into a @dateTime@ or may fail with a parse error.
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)
-- | Converts a zoned time to a @dateTime@.
fromZonedTime :: ZonedTime -> DateTime
fromZonedTime = fromUTCTime . zonedTimeToUTC
-- | Whether the given @dateTime@ is timezoned.
isZoned ::
DateTime
-> Bool
isZoned =
isn't pLocalTime
-- | Whether the given @dateTime@ is non-timezoned.
isUnzoned ::
DateTime
-> Bool
isUnzoned =
isn't pUTCTime
-- | Attempts to convert a @dateTime@ to a UTC time. The attempt fails
-- if the given @dateTime@ is non-timezoned.
toUTCTime ::
DateTime
-> Maybe UTCTime
toUTCTime =
(^? pUTCTime)
-- | Converts a UTC time to a timezoned @dateTime@.
fromUTCTime ::
UTCTime
-> DateTime
fromUTCTime =
(pUTCTime #)
-- | Attempts to convert a @dateTime@ to a local time. The attempt
-- fails if the given @dateTime@ is timezoned.
toLocalTime ::
DateTime
-> Maybe LocalTime
toLocalTime =
(^? pLocalTime)
-- | Converts a local time to a non-timezoned @dateTime@.
fromLocalTime ::
LocalTime
-> DateTime
fromLocalTime =
(pLocalTime #)
-- | Parses the string in a @dateTime@ then converts to a UTC time and
-- may fail with a parse error.
utcTime' ::
Text
-> Either String UTCTime
utcTime' txt =
dateTime' txt >>= maybe (Left err) Right . toUTCTime
where
err = "input time is non-timezoned"
-- | Parses the string in a @dateTime@ then converts to a UTC time and
-- may fail.
utcTime ::
Text
-> Maybe UTCTime
utcTime txt =
txt ^? dateTime >>= toUTCTime
-- | Parses the string in a @dateTime@ then converts to a local time
-- and may fail with a parse error.
localTime' ::
Text
-> Either String LocalTime
localTime' txt =
dateTime' txt >>= maybe (Left err) Right . toLocalTime
where
err = "input time is non-timezoned"
-- | Parses the string in a @dateTime@ then converts to a local time
-- time and may fail.
localTime ::
Text
-> Maybe LocalTime
localTime txt =
txt ^? dateTime >>= toLocalTime
-- | Parser of the @dateTime@ lexical representation.
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
-- | Parse timezone offset.
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'