xsd 0.5.0.1 → 0.6.2
raw patch · 9 files changed
Files
- ChangeLog +0/−8
- LICENCE +28/−0
- LICENSE +0/−28
- Setup.hs +2/−0
- Setup.lhs +0/−44
- changelog.md +18/−0
- src/Text/XML/XSD/DateTime.hs +248/−271
- test/doctests.hs +0/−32
- xsd.cabal +13/−39
− ChangeLog
@@ -1,8 +0,0 @@-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)
+ 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,44 +0,0 @@-#!/usr/bin/env runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Verbosity ( Verbosity )-import System.FilePath ( (</>) )--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys--\end{code}
+ 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/DateTime.hs view
@@ -1,52 +1,83 @@+{-# 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(..)- , isoEither- , isoEither'- , fold- , pUTCTime- , pLocalTime- , dateTime- , dateTime'- , isZoned- , isUnzoned- , fromZonedTime- , toUTCTime- , fromUTCTime- , toLocalTime- , fromLocalTime- , utcTime'- , utcTime- , localTime'- , localTime- ) where+(+ DateTime(..)+, ManyDateTime(..)+, Many1DateTime(..)+, HasDateTime(..)+, AsDateTime(..)+, isoEither+, fromZonedTime+) 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 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.Time-import Data.Time.Calendar.MonthDay (monthLength)+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 Test.QuickCheck.Instances ()+-- >>> 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)@@ -63,8 +94,55 @@ data DateTime = DtZoned UTCTime | DtUnzoned LocalTime- deriving (Eq, Ord)+ 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@@ -86,191 +164,157 @@ 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+ 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. ----- 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+-- >>> "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--- Just 2119-10-10T16:36:10.4Z+-- >>> "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--- Just 0009-10-09T13:10:10.783952Z+-- >>> "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--- Just 2009-10-10T03:10:10Z+-- >>> "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--- Just -2009-05-10T16:08:59Z+-- >>> "-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--- Just -19398-01-01T03:10:10Z+-- >>> "-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--- Just 2009-12-31T13:10:10+-- >>> "2009-12-31T13:10:10" ^? (_DateTime :: Prism' Text DateTime)+-- Just (DtUnzoned 2009-12-31 13:10:10) ----- >>> "2012-10-15T24:00:00" ^? dateTime--- Just 2012-10-16T00:00:00+-- >>> "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--- Just 2002-10-10T07:00:00Z+-- >>> "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--- Just 2002-10-09T19:00:00Z+-- >>> "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--- Just 000-1-10-10T00:00:00+-- >>> "-0001-10-10T00:00:00" ^? (_DateTime :: Prism' Text DateTime)+-- Just (DtUnzoned -0001-10-10 00:00:00) ----- >>> "0001-10-10T00:00:00" ^? dateTime--- Just 0001-10-10T00: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+-- >>> "2009-10-10T03:10:10-05" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:10:10+14:50" ^? dateTime+-- >>> "2009-10-10T03:10:10+14:50" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:10:1" ^? dateTime+-- >>> "2009-10-10T03:10:1" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T03:1:10" ^? dateTime+-- >>> "2009-10-10T03:1:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T0:10:10" ^? dateTime+-- >>> "2009-10-10T0:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-1T10:10:10" ^? dateTime+-- >>> "2009-10-1T10:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-1-10T10:10:10" ^? dateTime+-- >>> "2009-1-10T10:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "209-10-10T03:10:10" ^? dateTime+-- >>> "209-10-10T03:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-10-10T24:10:10" ^? dateTime+-- >>> "2009-10-10T24:10:10" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "0000-01-01T00:00:00" ^? dateTime+-- >>> "0000-01-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "2009-13-01T00:00:00" ^? dateTime+-- >>> "2009-13-01T00:00:00" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "+2009-10-01T04:20:40" ^? dateTime+-- >>> "+2009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> "002009-10-01T04:20:40" ^? dateTime+-- >>> "002009-10-01T04:20:40" ^? (_DateTime :: Prism' Text DateTime) -- Nothing ----- >>> dateTime # fromUTCTime (mkUTC 2119 10 10 16 36 10.4)+-- >>> (_DateTime :: Prism' Text DateTime) # review _UTCDateTime (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)+-- >>> (_DateTime :: Prism' Text 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)+-- >>> (_DateTime :: Prism' Text DateTime) # review _LocalDateTime (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+-- >>> (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"-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')+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") --- | 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")+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@@ -280,91 +324,12 @@ -- | 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+fromZonedTime = review _UTCDateTime . zonedTimeToUTC -- | Parser of the @dateTime@ lexical representation. parseDateTime ::- Parser DateTime+ (CharParsing p, Monad p) =>+ p DateTime parseDateTime = do yy <- yearParser _ <- char '-'@@ -384,52 +349,64 @@ -- | Parse timezone offset. parseOffset ::- Parser (Maybe Pico)+ (Monad p, CharParsing p) =>+ p (Maybe Pico) parseOffset =- (endOfInput *> pure Nothing)+ (Nothing <$ eof) <|>- (char 'Z' *> pure (Just 0))+ (Just 0 <$ char 'Z') <|>- (do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (-1))+ (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 ::- Parser Integer+ (Monad p, CharParsing p) =>+ p 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+ 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 ::- Parser Pico+ (Monad p, CharParsing p) =>+ p Pico secondParser = do d1 <- digit d2 <- digit- frac <- readFrac <$> (char '.' *> takeWhile isDigit)+ frac <- readFrac <$> (char '.' *> many digit) <|> pure 0 return (read [d1, d2] + frac) where- readFrac ds = read $ '0' : '.' : unpack ds+ readFrac ds = read $ '0' : '.' : ds p2imax ::+ (Monad p, CharParsing p) => Int- -> Parser 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+ then fail $ "value " <> show n <> " exceeded maximum " <> show m else return n where val c = ord c - ord '0'
− test/doctests.hs
@@ -1,32 +0,0 @@-module Main where--import Build_doctests (deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--main ::- IO ()-main =- getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
xsd.cabal view
@@ -1,35 +1,34 @@ name: xsd-version: 0.5.0.1+version: 0.6.2 license: BSD3-license-file: LICENSE+license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>-maintainer: Stefan Wehr <wehr@factisresearch.com>, Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>-copyright: 2010-2014 Tony Morris, Stefan Wehr+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://github.com/tonymorris/xsd-bug-reports: https://github.com/tonymorris/xsd/issues+homepage: https://gitlab.com/tonymorris/xsd+bug-reports: https://gitlab.com/tonymorris/xsd/issues cabal-version: >= 1.10-build-type: Custom-extra-source-files: ChangeLog+build-type: Simple+extra-source-files: changelog.md source-repository head type: git- location: git@github.com:tonymorris/xsd.git--flag small_base- description: Choose the new, split-up base package.+ location: git@gitlab.com:tonymorris/xsd.git library default-language: Haskell2010 build-depends: base < 5 && >= 4.5- , attoparsec >= 0.11 , text >= 1.0 , time >= 1.2.0.3- , lens >= 4+ , lens >= 4 && < 6+ , parsec >= 3.1 && < 3.2+ , parsers >= 0.12 && < 0.13+ , semigroupoids >= 5 && < 6 ghc-options: -Wall@@ -43,28 +42,3 @@ exposed-modules: Text.XML.XSD Text.XML.XSD.DateTime--test-suite doctests- type:- exitcode-stdio-1.0-- main-is:- doctests.hs-- default-language:- Haskell2010-- build-depends:- base < 5 && >= 3- , doctest >= 0.9.7- , filepath >= 1.3- , directory >= 1.1- , QuickCheck >= 2.0- , quickcheck-instances >= 0.3-- ghc-options:- -Wall- -threaded-- hs-source-dirs:- test