xsd 0.3.7 → 0.6.2
raw patch · 10 files changed
Files
- LICENCE +28/−0
- LICENSE +0/−28
- Setup.hs +2/−0
- Setup.lhs +0/−3
- Text/XML/XSD.hs +0/−5
- Text/XML/XSD/DateTime.hs +0/−187
- changelog.md +18/−0
- src/Text/XML/XSD.hs +122/−0
- src/Text/XML/XSD/DateTime.hs +412/−0
- xsd.cabal +41/−23
+ LICENCE view
@@ -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.
− LICENSE
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain
− Text/XML/XSD.hs
@@ -1,5 +0,0 @@-module Text.XML.XSD(- module Text.XML.XSD.DateTime- ) where--import Text.XML.XSD.DateTime
− Text/XML/XSD/DateTime.hs
@@ -1,187 +0,0 @@--- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>-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 <http://www.w3.org/TR/xmlschema-2/#dateTime>-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
+ changelog.md view
@@ -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)
+ src/Text/XML/XSD.hs view
@@ -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
+ src/Text/XML/XSD/DateTime.hs view
@@ -0,0 +1,412 @@+{-# 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'
xsd.cabal view
@@ -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 <wehr@factisresearch.com>-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 <wehr@factisresearch.com>+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