diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,28 @@ +Copyright 2009 Tony Morris +Copyright 2013 Stefan Wehr + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,28 +0,0 @@ -Copyright 2009 Tony Morris -Copyright 2013 Stefan Wehr - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/Text/XML/XSD.hs b/Text/XML/XSD.hs deleted file mode 100644 --- a/Text/XML/XSD.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Text.XML.XSD( - module Text.XML.XSD.DateTime - ) where - -import Text.XML.XSD.DateTime diff --git a/Text/XML/XSD/DateTime.hs b/Text/XML/XSD/DateTime.hs deleted file mode 100644 --- a/Text/XML/XSD/DateTime.hs +++ /dev/null @@ -1,187 +0,0 @@ --- | XSD @dateTime@ data structure -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 - --- | XSD @dateTime@ data structure -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) - --- | Parses the string into a @dateTime@ or may fail with a parse error. -dateTime' :: String -> Either ParseError DateTime -dateTime' = parse parseDateTime "DateTime parser" - --- | Parses the string into a @dateTime@ or may fail. -dateTime :: String -> Maybe DateTime -dateTime = either (const Nothing) Just . dateTime' - --- | Converts a @dateTime@ to a zoned time. -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) - --- | Converts a zoned time to a @dateTime@. -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)) - --- | Parses the string in a @dateTime@ then converts to a zoned time and may fail with a parse error. -zonedTime' :: String -> Either ParseError ZonedTime -zonedTime' = fmap toZonedTime . dateTime' - --- | Parses the string in a @dateTime@ then converts to a zoned time and may fail. -zonedTime :: String -> Maybe ZonedTime -zonedTime = fmap toZonedTime . dateTime - --- | Converts a @dateTime@ to a UTC time. -toUTCTime :: DateTime -> UTCTime -toUTCTime = uncurry localTimeToUTC . (zonedTimeZone &&& zonedTimeToLocalTime) . toZonedTime - --- | Converts a UTC time to a @dateTime@. -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) - --- | Parses the string in a @dateTime@ then converts to a UTC time and may fail with a parse error. -utcTime' :: String -> Either ParseError UTCTime -utcTime' = fmap toUTCTime . dateTime' - --- | Parses the string in a @dateTime@ then converts to a UTC time and may fail. -utcTime :: String -> Maybe UTCTime -utcTime = fmap toUTCTime . dateTime - --- not exported - -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 - --- examples = ["2009-10-10T03:10:10-05:00", "2119-10-10T03:10:10.4-15:26", "0009-10-10T03:10:10+15:00", "2009-10-10T03:10:10Z", "-2009-05-10T21:08:59-05:00", "-9399-12-31T13:10:10+15:00", "-2009-10-10T03:10:10Z"] - --- not exported - -trimTail :: (a -> Bool) -> [a] -> [a] -trimTail = (reverse .) . (. reverse) . dropWhile diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,18 @@ +0.6.2 (2021) + * Add more string-like instances. + +0.6.1 (2021) + * Add classy optics. + +0.6.0 (2021) + * Refactoring. + * Update version bounds. + +0.5.0 (2014-0214) + * Refactoring + * Introduces lenses, isomorphisms and prisms. + * Dependencies have minimum version bounds. + * Tests are implemented using doctest. + +0.4.0 (2013-0809) + * Major refactoring by rycee (not backwards-compatible) diff --git a/src/Text/XML/XSD.hs b/src/Text/XML/XSD.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/XSD.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} + +module Text.XML.XSD + ( E18 + , Atto + , boolean + , toBoolean + , decimal + , integer + , toSigned + , long + , int + , short + , byte + , unsignedInteger + , unsignedLong + , unsignedInt + , unsignedShort + , unsignedByte + , float + , double + , fastDouble + , module Text.XML.XSD.DateTime + ) where + +import Text.XML.XSD.DateTime + +import Prelude(String, Double, Float, Integral, Eq(..), (||), otherwise) +import Control.Monad (Monad(..), when) +import Data.Bool(Bool(..)) +import Data.Fixed (Fixed, HasResolution(..), resolution) +import Data.Either(Either(..)) +import Data.Function((.), ($)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List((++)) +import Data.Text (Text, unpack) +import Data.Text.Lazy(toStrict) +import Data.Text.Lazy.Builder(toLazyText) +import qualified Data.Text.Lazy.Builder.Int as TBI(decimal) +import qualified Data.Text.Read as TR(rational, double, decimal, signed) +import Data.Word (Word8, Word16, Word32, Word64) + +data E18 + +instance HasResolution E18 where + resolution _ = 1000000000000000000 + +type Atto = Fixed E18 + +checkReader :: Either String (a, Text) -> Either String a +checkReader res = + do (val, t) <- res + when (t /= "") $ Left "leftovers" + return val + +-- checkReader (Left msg) = Left msg +-- checkReader (Right (val, t)) +-- | t /= "" = Left "leftovers" +-- | otherwise = Right val + +boolean :: Text -> Either String Bool +boolean t + | t == "true" || t == "1" = Right True + | t == "false" || t == "0" = Right False + | otherwise = Left $ "invalid boolean '" ++ unpack t ++ "'" + +toBoolean :: Bool -> Text +toBoolean True = "true" +toBoolean False = "false" + +decimal :: Text -> Either String Atto +decimal = checkReader . TR.rational + +signed :: Integral a => Text -> Either String a +signed = checkReader . TR.signed TR.decimal + +unsigned :: Integral a => Text -> Either String a +unsigned = checkReader . TR.decimal + +toSigned :: Integral a => a -> Text +toSigned = toStrict . toLazyText . TBI.decimal + +integer :: Integral a => Text -> Either String a +integer = signed + +long :: Text -> Either String Int64 +long = signed + +int :: Text -> Either String Int32 +int = signed + +short :: Text -> Either String Int16 +short = signed + +byte :: Text -> Either String Int8 +byte = signed + +-- | What XSD calls @nonNegativeInteger@. +unsignedInteger :: Integral a => Text -> Either String a +unsignedInteger = unsigned + +unsignedLong :: Text -> Either String Word64 +unsignedLong = unsigned + +unsignedInt :: Text -> Either String Word32 +unsignedInt = unsigned + +unsignedShort :: Text -> Either String Word16 +unsignedShort = unsigned + +unsignedByte :: Text -> Either String Word8 +unsignedByte = unsigned + +float :: Text -> Either String Float +float = checkReader . TR.rational + +double :: Text -> Either String Double +double = checkReader . TR.rational + +fastDouble :: Text -> Either String Double +fastDouble = checkReader . TR.double diff --git a/src/Text/XML/XSD/DateTime.hs b/src/Text/XML/XSD/DateTime.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/XSD/DateTime.hs @@ -0,0 +1,412 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | XSD @dateTime@ data structure +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 +-- . 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' diff --git a/xsd.cabal b/xsd.cabal --- a/xsd.cabal +++ b/xsd.cabal @@ -1,26 +1,44 @@ -Name: xsd -Version: 0.3.7 -License: BSD3 -License-File: LICENSE -Synopsis: XML Schema data structures -Description: XML Schema data structures (XSD) -Homepage: https://github.com/skogsbaer/xsd -Category: XML -Author: Tony Morris -Maintainer: Stefan Wehr -Copyright: 2010 Tony Morris, 2013 Stefan Wehr -build-type: Simple -cabal-version: >= 1.2 +name: xsd +version: 0.6.2 +license: BSD3 +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>, Stefan Wehr +copyright: 2010-2021 Tony Morris, Stefan Wehr +synopsis: XML Schema data structures +category: XML +description: XML Schema data structures (XSD) +homepage: https://gitlab.com/tonymorris/xsd +bug-reports: https://gitlab.com/tonymorris/xsd/issues +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: changelog.md -Flag small_base - Description: Choose the new, split-up base package. +source-repository head + type: git + location: git@gitlab.com:tonymorris/xsd.git -Library - if flag(small_base) - Build-Depends: base < 5 && >= 3, parsec, time >= 1.2.0.3 - else - Build-Depends: base < 5 && >= 3, parsec, time >= 1.2.0.3 +library + default-language: + Haskell2010 - GHC-Options: -Wall - Exposed-Modules: Text.XML.XSD - Text.XML.XSD.DateTime + build-depends: base < 5 && >= 4.5 + , text >= 1.0 + , time >= 1.2.0.3 + , lens >= 4 && < 6 + , parsec >= 3.1 && < 3.2 + , parsers >= 0.12 && < 0.13 + , semigroupoids >= 5 && < 6 + + ghc-options: + -Wall + + default-extensions: + NoImplicitPrelude + + hs-source-dirs: + src + + exposed-modules: + Text.XML.XSD + Text.XML.XSD.DateTime