xsd-0.6.2: src/Text/XML/XSD/DateTime.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
-- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>
module Text.XML.XSD.DateTime
(
DateTime(..)
, ManyDateTime(..)
, Many1DateTime(..)
, HasDateTime(..)
, AsDateTime(..)
, isoEither
, fromZonedTime
) where
import Control.Applicative (pure, (<$>), (*>), (<|>))
import Control.Monad (Monad(..), when)
import Control.Lens
( view,
iso,
prism',
review,
Iso',
Lens',
Prism',
Traversal',
Traversal1' )
import Data.Bool ( Bool(False, True), (&&), (||) )
import Data.Char (Char, ord)
import Data.Either(Either(..), either)
import Data.Eq ( Eq(..) )
import Data.Fixed (Pico, showFixed)
import Data.Function((.), id, ($), const)
import Data.Functor((<$))
import Data.Functor.Apply(WrappedApplicative(WrapApplicative, unwrapApplicative))
import Data.Int ( Int )
import Data.Maybe (Maybe(Nothing, Just))
import Data.Ord ( Ord((>), (<)) )
import Data.Text(Text)
import qualified Data.Text.Lazy as TL(Text, toStrict)
import Data.Text.Lazy.Builder(Builder, toLazyText, fromString)
import Data.Text.Lazy.Builder.Int (decimal)
import Data.Text.Lens ( unpacked, IsText(packed) )
import qualified Data.Text.Read as TR(decimal)
import Data.Semigroup ((<>))
import Data.String(String)
import Data.Time
( addDays,
fromGregorian,
toGregorian,
isLeapYear,
addUTCTime,
utcToLocalTime,
timeOfDayToTime,
utc,
zonedTimeToUTC,
UTCTime(UTCTime),
LocalTime(LocalTime),
TimeOfDay(TimeOfDay),
ZonedTime )
import Data.Time.Calendar.MonthDay (monthLength)
import GHC.Show(Show(show))
import GHC.Generics(Generic)
import Prelude(Num(negate, abs, (*), (+), (-)), Integer, read, fromIntegral, realToFrac)
import Text.Parsec(parse)
import Text.Parser.Char ( digit, CharParsing(char) )
import Text.Parser.Combinators ( many, Parsing(eof) )
import qualified Data.Text as Text(pack)
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Functor(fmap)
-- >>> import Prelude(signum)
-- >>> import Control.Lens
-- >>> import Data.Time
-- >>> 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, Show, Generic)
class ManyDateTime a where
_DateTime_ :: Traversal' a DateTime
default _DateTime_ :: Many1DateTime a => Traversal' a DateTime
_DateTime_ f = unwrapApplicative . _DateTime1_ (WrapApplicative . f)
instance ManyDateTime DateTime where
class Many1DateTime a where
_DateTime1_ :: Traversal1' a DateTime
default _DateTime1_ :: HasDateTime a => Traversal1' a DateTime
_DateTime1_ = dateTime
instance Many1DateTime DateTime where
class HasDateTime a where
dateTime :: Lens' a DateTime
getDateTime :: a -> DateTime
getDateTime = view dateTime
instance HasDateTime DateTime where
dateTime = id
class AsDateTime a where
_DateTime :: Prism' a DateTime
_UTCDateTime :: Prism' a UTCTime
_UTCDateTime = _DateTime . _UTCDateTime
_LocalDateTime :: Prism' a LocalTime
_LocalDateTime = _DateTime . _LocalDateTime
instance AsDateTime DateTime where
_DateTime = id
_UTCDateTime =
prism'
DtZoned
(\case
DtZoned x -> Just x
_ -> Nothing
)
_LocalDateTime =
prism'
DtUnzoned
(\case
DtUnzoned x -> Just x
_ -> Nothing
)
-- _LocalDateTime = undefined
-- | 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)
-- | The isomorphism between a @DateTime@ and @Either UTCTime LocalTime@
isoEither ::
Iso'
(Either UTCTime LocalTime)
DateTime
isoEither =
iso (either DtZoned DtUnzoned) (\case DtZoned e -> Left e
DtUnzoned q -> Right q)
-- | A prism that parses the string into a @DateTime@ and converts the
-- @DateTime@ into a string.
--
-- >>> "2009-10-10T03:10:10-05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2009-10-10 08:10:10 UTC)
--
-- >>> "2119-10-10T03:10:10.4-13:26" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2119-10-10 16:36:10.4 UTC)
--
-- >>> "0009-10-10T03:10:10.783952+14:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 0009-10-09 13:10:10.783952 UTC)
--
-- >>> "2009-10-10T03:10:10Z" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2009-10-10 03:10:10 UTC)
--
-- >>> "-2009-05-10T21:08:59+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned -2009-05-10 16:08:59 UTC)
--
-- >>> "-19399-12-31T13:10:10-14:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned -19398-01-01 03:10:10 UTC)
--
-- >>> "2009-12-31T13:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 2009-12-31 13:10:10)
--
-- >>> "2012-10-15T24:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 2012-10-16 00:00:00)
--
-- >>> "2002-10-10T12:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2002-10-10 07:00:00 UTC)
--
-- >>> "2002-10-10T00:00:00+05:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtZoned 2002-10-09 19:00:00 UTC)
--
-- >>> "-0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned -0001-10-10 00:00:00)
--
-- >>> "0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Just (DtUnzoned 0001-10-10 00:00:00)
--
-- >>> "2009-10-10T03:10:10-05" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:10:10+14:50" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:10:1" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T03:1:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T0:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-1T10:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-1-10T10:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "209-10-10T03:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-10-10T24:10:10" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "0000-01-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "2009-13-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "+2009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> "002009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime)
-- Nothing
--
-- >>> (_DateTime :: Prism' Text DateTime) # review _UTCDateTime (mkUTC 2119 10 10 16 36 10.4)
-- "2119-10-10T16:36:10.4Z"
--
-- >>> (_DateTime :: Prism' Text DateTime) # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0)
-- "2010-04-07T11:47:20.001Z"
--
-- >>> (_DateTime :: Prism' Text DateTime) # review _LocalDateTime (mkLocal 13 2 4 20 20 20)
-- "0013-02-04T20:20:20"
--
-- >>> (review (_DateTime :: Prism' Text DateTime)) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? (_DateTime :: Prism' Text DateTime)) -- issue 2
-- Just "2010-04-07T11:47:20.001Z"
instance AsDateTime Text where
_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 =
TL.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 . parse (parseDateTime <|> fail "bad date time") "DateTime")
instance ManyDateTime TL.Text where
_DateTime_ =
_DateTime
instance AsDateTime TL.Text where
_DateTime =
unpacked . (packed :: Iso' String Text) . _DateTime
instance ManyDateTime [Char] where
_DateTime_ =
_DateTime
instance AsDateTime [Char] where
_DateTime =
(packed :: Iso' String Text) . _DateTime
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 = review _UTCDateTime . zonedTimeToUTC
-- | Parser of the @dateTime@ lexical representation.
parseDateTime ::
(CharParsing p, Monad p) =>
p 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 ::
(Monad p, CharParsing p) =>
p (Maybe Pico)
parseOffset =
(Nothing <$ eof)
<|>
(Just 0 <$ char 'Z')
<|>
(do sign <- (1 <$ char '+') <|> ((-1) <$ char '-')
hh <- fromIntegral <$> p2imax 14
_ <- char ':'
mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59)
return . Just $ sign * (hh * 3600 + mm * 60))
yearParser ::
(Monad p, CharParsing p) =>
p Integer
yearParser =
let lengthLT4 (_:_:_:_:_) =
False
lengthLT4 _ =
True
lengthGT4_c1 c (x:_:_:_:_:_) =
c == x
lengthGT4_c1 _ _ =
False
in do sign <- ((-1) <$ char '-') <|> pure 1
ds <- many digit
when (lengthLT4 ds)
$ fail "need at least four digits in year"
when (lengthGT4_c1 '0' ds)
$ fail "leading zero in year"
let Right (absyear, _) = TR.decimal (Text.pack ds)
when (absyear == 0)
$ fail "year zero disallowed"
return $ sign * absyear
secondParser ::
(Monad p, CharParsing p) =>
p Pico
secondParser =
do d1 <- digit
d2 <- digit
frac <- readFrac <$> (char '.' *> many digit)
<|> pure 0
return (read [d1, d2] + frac)
where
readFrac ds = read $ '0' : '.' : ds
p2imax ::
(Monad p, CharParsing p) =>
Int
-> p 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'