xsd 0.4.0.1 → 0.5.0.0
raw patch · 9 files changed
+708/−431 lines, 9 filesdep +directorydep +doctestdep +filepathdep −HUnitdep −bytestringdep −test-frameworkdep ~QuickCheckdep ~attoparsecdep ~basebuild-type:Customsetup-changed
Dependencies added: directory, doctest, filepath, lens
Dependencies removed: HUnit, bytestring, test-framework, test-framework-hunit, test-framework-quickcheck2
Dependency ranges changed: QuickCheck, attoparsec, base, quickcheck-instances, text, time
Files
- ChangeLog +8/−0
- Setup.lhs +43/−2
- Text/XML/XSD.hs +0/−120
- Text/XML/XSD/DateTime.hs +0/−234
- src/Text/XML/XSD.hs +122/−0
- src/Text/XML/XSD/DateTime.hs +435/−0
- test/doctests.hs +32/−0
- test/main.hs +0/−38
- xsd.cabal +68/−37
+ ChangeLog view
@@ -0,0 +1,8 @@+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)
Setup.lhs view
@@ -1,3 +1,44 @@ #!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain+\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}
− Text/XML/XSD.hs
@@ -1,120 +0,0 @@-{-# 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 Control.Monad (when)-import Data.Fixed (Fixed, HasResolution(..), resolution)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Builder.Int as TBI-import qualified Data.Text.Read as TR-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 =- if t == "true" || t == "1"- then Right True- else if t == "false" || t == "0"- then Right False- else Left $ "invalid boolean '" ++ T.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 = TL.toStrict . TB.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
− Text/XML/XSD/DateTime.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>-module Text.XML.XSD.DateTime- ( DateTime(..)- , isZoned- , isUnzoned- , dateTime'- , dateTime- , toText- , fromZonedTime- , toUTCTime- , fromUTCTime- , toLocalTime- , fromLocalTime- , utcTime'- , utcTime- , localTime'- , localTime- ) where--import Control.Applicative (pure, (<$>), (*>), (<|>))-import Control.Monad (when)-import Data.Attoparsec.Text (Parser, char, digit)-import qualified Data.Attoparsec.Text as A-import Data.Char (isDigit, ord)-import Data.Fixed (Pico, showFixed)-import Data.Maybe (maybeToList)-import Data.Monoid ((<>))-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Lazy.Builder.Int as TBI-import qualified Data.Text.Read as TR-import Data.Time-import Data.Time.Calendar.MonthDay (monthLength)---- | 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)---- | Internal helper that creates a date time. Note, if the given hour--- is 24 then the minutes and seconds are assumed to be 0.-mkDateTime :: Integer -- ^ Year- -> Int -- ^ Month- -> Int -- ^ Day- -> Int -- ^ Hours- -> Int -- ^ Minutes- -> Pico -- ^ Seconds- -> Maybe Pico -- ^ Time zone offset- -> DateTime-mkDateTime y m d hh mm ss mz =- case mz of- Just z -> DtZoned $ addUTCTime (negate $ realToFrac z) uTime- Nothing -> DtUnzoned lTime- where- day = addDays (if hh == 24 then 1 else 0) (fromGregorian y m d)- tod = TimeOfDay (if hh == 24 then 0 else hh) mm ss- lTime = LocalTime day tod- uTime = UTCTime day (timeOfDayToTime tod)--instance Show DateTime where- show = T.unpack . toText--instance Read DateTime where- readList s = [(maybeToList (dateTime . T.pack $ s), [])]---- | Parses the string into a @dateTime@ or may fail with a parse error.-dateTime' :: Text -> Either String DateTime-dateTime' = A.parseOnly (parseDateTime <|> fail "bad date time")---- | Parses the string into a @dateTime@ or may fail.-dateTime :: Text -> Maybe DateTime-dateTime = either (const Nothing) Just . dateTime'--toText :: DateTime -> Text-toText = TL.toStrict . TB.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--buildInt4 :: Integer -> TB.Builder-buildInt4 year =- let absYear = abs year- k x = if absYear < x then ("0" <>) else id- in k 1000 . k 100 . k 10 $ TBI.decimal year--buildUInt2 :: Int -> TB.Builder-buildUInt2 x = (if x < 10 then ("0" <>) else id) $ TBI.decimal x--buildSeconds :: Pico -> TB.Builder-buildSeconds secs = (if secs < 10 then ("0" <>) else id)- $ TB.fromString (showFixed True secs)---- | Converts a zoned time to a @dateTime@.-fromZonedTime :: ZonedTime -> DateTime-fromZonedTime = fromUTCTime . zonedTimeToUTC---- | Whether the given @dateTime@ is timezoned.-isZoned :: DateTime -> Bool-isZoned (DtZoned _) = True-isZoned (DtUnzoned _) = False---- | Whether the given @dateTime@ is non-timezoned.-isUnzoned :: DateTime -> Bool-isUnzoned = not . isZoned---- | Attempts to convert a @dateTime@ to a UTC time. The attempt fails--- if the given @dateTime@ is non-timezoned.-toUTCTime :: DateTime -> Maybe UTCTime-toUTCTime (DtZoned time) = Just time-toUTCTime _ = Nothing---- | Converts a UTC time to a timezoned @dateTime@.-fromUTCTime :: UTCTime -> DateTime-fromUTCTime = DtZoned---- | Attempts to convert a @dateTime@ to a local time. The attempt--- fails if the given @dateTime@ is timezoned.-toLocalTime :: DateTime -> Maybe LocalTime-toLocalTime (DtUnzoned time) = Just time-toLocalTime _ = Nothing---- | Converts a local time to an non-timezoned @dateTime@.-fromLocalTime :: LocalTime -> DateTime-fromLocalTime = DtUnzoned---- | 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 = dateTime txt >>= 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 = dateTime txt >>= toLocalTime---- | Parser of the @dateTime@ lexical representation.-parseDateTime :: Parser DateTime-parseDateTime = do yy <- yearParser- _ <- char '-'- mm <- p2imax 12- _ <- char '-'- dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm)- _ <- char 'T'- hhh <- p2imax 24- _ <- char ':'- mmm <- p2imax 59- _ <- char ':'- sss <- secondParser- when (hhh == 24 && (mmm /= 0 || sss /= 0))- $ fail "invalid time, past 24:00:00"- o <- parseOffset- return $ mkDateTime yy mm dd hhh mmm sss o---- | Parse timezone offset.-parseOffset :: Parser (Maybe Pico)-parseOffset = (A.endOfInput *> pure Nothing)- <|>- (char 'Z' *> pure (Just 0))- <|>- (do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (-1))- hh <- fromIntegral <$> p2imax 14- _ <- char ':'- mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59)- return . Just $ sign * (hh * 3600 + mm * 60))--yearParser :: Parser Integer-yearParser = do sign <- (char '-' *> pure (-1)) <|> pure 1- ds <- A.takeWhile isDigit- when (T.length ds < 4)- $ fail "need at least four digits in year"- when (T.length ds > 4 && T.head ds == '0')- $ fail "leading zero in year"- let Right (absyear, _) = TR.decimal ds- when (absyear == 0)- $ fail "year zero disallowed"- return $ sign * absyear--secondParser :: Parser Pico-secondParser = do d1 <- digit- d2 <- digit- frac <- readFrac <$> (char '.' *> A.takeWhile isDigit)- <|> pure 0- return (read [d1, d2] + frac)- where- readFrac ds = read $ '0' : '.' : T.unpack ds--p2imax :: Int -> Parser Int-p2imax m = do a <- digit- b <- digit- let n = 10 * val a + val b- if n > m- then fail $ "value " ++ show n ++ " exceeded maximum " ++ show m- else return n- where- val c = ord c - ord '0'
+ 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,435 @@+{-# LANGUAGE OverloadedStrings #-}++-- | XSD @dateTime@ data structure <http://www.w3.org/TR/xmlschema-2/#dateTime>+module Text.XML.XSD.DateTime+ ( DateTime(..)+ , isoEither+ , isoEither'+ , fold+ , pUTCTime+ , pLocalTime+ , dateTime+ , dateTime'+ , isZoned+ , isUnzoned+ , fromZonedTime+ , toUTCTime+ , fromUTCTime+ , toLocalTime+ , fromLocalTime+ , utcTime'+ , utcTime+ , localTime'+ , localTime+ ) where++import Prelude(Show(..), Read(..), Eq(..), Ord(..), Num(..), Int, Integer, String, (&&), (||), read, fromIntegral, realToFrac)+import Control.Applicative (pure, (<$>), (*>), (<|>))+import Control.Monad (Monad(..), when)+import Control.Lens(Iso', Prism', _Left, _Right, iso, prism', from, isn't, (#), (^?))+import Data.Attoparsec.Text(Parser, char, digit, parseOnly, endOfInput, takeWhile)+import Data.Bool(Bool(..))+import Data.Char (isDigit, ord)+import Data.Either(Either(..), either)+import Data.Fixed (Pico, showFixed)+import Data.Function((.), id, ($), const)+import Data.List((++))+import Data.Maybe (Maybe(..), maybeToList, maybe)+import Data.Monoid ((<>))+import Data.Text(Text, pack, unpack, length, head)+import Data.Text.Lazy as TL(toStrict)+import Data.Text.Lazy.Builder(Builder, toLazyText, fromString)+import Data.Text.Lazy.Builder.Int (decimal)+import qualified Data.Text.Read as TR(decimal)+import Data.Time+import Data.Time.Calendar.MonthDay (monthLength)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Test.QuickCheck.Instances ()+-- >>> let mkLocal :: Integer -> Int -> Int -> Int -> Int -> Pico -> LocalTime; mkLocal y m d hh mm ss = LocalTime (fromGregorian y m d) (TimeOfDay hh mm ss)+-- >>> let mkUTC :: Integer -> Int -> Int -> Int -> Int -> Pico -> UTCTime; mkUTC y m d hh mm ss = localTimeToUTC utc (mkLocal y m d hh mm ss)+-- >>> let mkZoned :: Integer -> Int -> Int -> Int -> Int -> Pico -> Int -> Int -> ZonedTime; mkZoned y m d hh mm ss zh zm = ZonedTime (mkLocal y m d hh mm ss) (TimeZone offset False "") where offset = signum zh * (abs zh * 60 + zm)++-- | XSD @dateTime@ data structure+-- <http://www.w3.org/TR/xmlschema-2/#dateTime>. Briefly, a @dateTime@+-- uses the Gregorian calendar and may or may not have an associated+-- timezone. If it has a timezone, then the canonical representation+-- of that date time is in UTC.+--+-- Note, it is not possible to establish a total order on @dateTime@+-- since non-timezoned are considered to belong to some unspecified+-- timezone.+data DateTime =+ DtZoned UTCTime+ | DtUnzoned LocalTime+ deriving Eq++-- | Internal helper that creates a date time. Note, if the given hour+-- is 24 then the minutes and seconds are assumed to be 0.+mkDateTime+ :: Integer -- ^ Year+ -> Int -- ^ Month+ -> Int -- ^ Day+ -> Int -- ^ Hours+ -> Int -- ^ Minutes+ -> Pico -- ^ Seconds+ -> Maybe Pico -- ^ Time zone offset+ -> DateTime+mkDateTime y m d hh mm ss mz =+ case mz of+ Just z -> DtZoned $ addUTCTime (negate $ realToFrac z) uTime+ Nothing -> DtUnzoned lTime+ where+ day = addDays (if hh == 24 then 1 else 0) (fromGregorian y m d)+ tod = TimeOfDay (if hh == 24 then 0 else hh) mm ss+ lTime = LocalTime day tod+ uTime = UTCTime day (timeOfDayToTime tod)++instance Show DateTime where+ show = unpack . (dateTime #)++instance Read DateTime where+ readList s = [(maybeToList (pack s ^? dateTime), [])]++-- | The isomorphism between a @DateTime@ and @Either UTCTime LocalTime@+isoEither ::+ Iso'+ (Either UTCTime LocalTime)+ DateTime+isoEither =+ iso (either DtZoned DtUnzoned) (\t -> case t of DtZoned e -> Left e+ DtUnzoned q -> Right q)++-- | The isomorphism between a @DateTime@ and @Either LocalTime UTCTime@+isoEither' ::+ Iso'+ (Either LocalTime UTCTime)+ DateTime+isoEither' =+ iso (either DtUnzoned DtZoned) (\t -> case t of DtUnzoned q -> Left q+ DtZoned e -> Right e)++-- | Reduction on a @DateTime@.+fold ::+ (LocalTime -> a)+ -> (UTCTime -> a)+ -> DateTime+ -> a+fold z _ (DtUnzoned q) =+ z q+fold _ z (DtZoned e) =+ z e++-- | A prism that views the @UTCTime@ component of a @DateTime@.+pUTCTime ::+ Prism' DateTime UTCTime+pUTCTime =+ from isoEither . _Left++-- | A prism that views the @LocalTime@ component of a @DateTime@.+pLocalTime ::+ Prism' DateTime LocalTime+pLocalTime =+ from isoEither . _Right++-- | A prism that parses the string into a @DateTime@ and converts the+-- @DateTime@ into a string.+--+-- prop> Just (DtZoned t) == (dateTime # fromUTCTime t) ^? dateTime+--+-- prop> Just (DtUnzoned t) == (dateTime # fromLocalTime t) ^? dateTime+--+-- >>> "2009-10-10T03:10:10-05:00" ^? dateTime+-- Just 2009-10-10T08:10:10Z+--+-- >>> "2119-10-10T03:10:10.4-13:26" ^? dateTime+-- Just 2119-10-10T16:36:10.4Z+--+-- >>> "0009-10-10T03:10:10.783952+14:00" ^? dateTime+-- Just 0009-10-09T13:10:10.783952Z+--+-- >>> "2009-10-10T03:10:10Z" ^? dateTime+-- Just 2009-10-10T03:10:10Z+--+-- >>> "-2009-05-10T21:08:59+05:00" ^? dateTime+-- Just -2009-05-10T16:08:59Z+--+-- >>> "-19399-12-31T13:10:10-14:00" ^? dateTime+-- Just -19398-01-01T03:10:10Z+--+-- >>> "2009-12-31T13:10:10" ^? dateTime+-- Just 2009-12-31T13:10:10+--+-- >>> "2012-10-15T24:00:00" ^? dateTime+-- Just 2012-10-16T00:00:00+--+-- >>> "2002-10-10T12:00:00+05:00" ^? dateTime+-- Just 2002-10-10T07:00:00Z+--+-- >>> "2002-10-10T00:00:00+05:00" ^? dateTime+-- Just 2002-10-09T19:00:00Z+--+-- >>> "-0001-10-10T00:00:00" ^? dateTime+-- Just 000-1-10-10T00:00:00+--+-- >>> "0001-10-10T00:00:00" ^? dateTime+-- Just 0001-10-10T00:00:00+--+-- >>> "2009-10-10T03:10:10-05" ^? dateTime+-- Nothing+--+-- >>> "2009-10-10T03:10:10+14:50" ^? dateTime+-- Nothing+--+-- >>> "2009-10-10T03:10:1" ^? dateTime+-- Nothing+--+-- >>> "2009-10-10T03:1:10" ^? dateTime+-- Nothing+--+-- >>> "2009-10-10T0:10:10" ^? dateTime+-- Nothing+--+-- >>> "2009-10-1T10:10:10" ^? dateTime+-- Nothing+--+-- >>> "2009-1-10T10:10:10" ^? dateTime+-- Nothing+--+-- >>> "209-10-10T03:10:10" ^? dateTime+-- Nothing+--+-- >>> "2009-10-10T24:10:10" ^? dateTime+-- Nothing+--+-- >>> "0000-01-01T00:00:00" ^? dateTime+-- Nothing+--+-- >>> "2009-13-01T00:00:00" ^? dateTime+-- Nothing+--+-- >>> "+2009-10-01T04:20:40" ^? dateTime+-- Nothing+--+-- >>> "002009-10-01T04:20:40" ^? dateTime+-- Nothing+--+-- >>> dateTime # fromUTCTime (mkUTC 2119 10 10 16 36 10.4)+-- "2119-10-10T16:36:10.4Z"+--+-- >>> dateTime # fromZonedTime (mkZoned 2010 04 07 13 47 20.001 2 0)+-- "2010-04-07T11:47:20.001Z"+--+-- >>> dateTime # fromLocalTime (mkLocal 13 2 4 20 20 20)+-- "0013-02-04T20:20:20"+--+-- >>> (dateTime #) `fmap` ("2010-04-07T13:47:20.001+02:00" ^? dateTime) -- issue 2+-- Just "2010-04-07T11:47:20.001Z"+dateTime ::+ Prism' Text DateTime+dateTime =+ let buildUInt2 ::+ Int+ -> Builder+ buildUInt2 x =+ (if x < 10 then ("0" <>) else id) $ decimal x+ buildInt4 ::+ Integer+ -> Builder+ buildInt4 year =+ let absYear = abs year+ k x = if absYear < x then ("0" <>) else id+ in k 1000 . k 100 . k 10 $ decimal year+ toText ::+ DateTime+ -> Text+ toText =+ toStrict . toLazyText . dtBuilder+ where+ dtBuilder (DtZoned uTime) = ltBuilder (utcToLocalTime utc uTime) <> "Z"+ dtBuilder (DtUnzoned lTime) = ltBuilder lTime+ ltBuilder (LocalTime day (TimeOfDay hh mm sss)) =+ let (y, m, d) = toGregorian day+ in buildInt4 y+ <> "-"+ <> buildUInt2 m+ <> "-"+ <> buildUInt2 d+ <> "T"+ <> buildUInt2 hh+ <> ":"+ <> buildUInt2 mm+ <> ":"+ <> buildSeconds sss+ in prism' toText (either (const Nothing) Just . dateTime')++-- | Parses the string into a @dateTime@ or may fail with a parse error.+dateTime' ::+ Text+ -> Either String DateTime+dateTime' =+ parseOnly (parseDateTime <|> fail "bad date time")++buildSeconds ::+ Pico+ -> Builder+buildSeconds secs =+ (if secs < 10 then ("0" <>) else id)+ $ fromString (showFixed True secs)++-- | Converts a zoned time to a @dateTime@.+fromZonedTime :: ZonedTime -> DateTime+fromZonedTime = fromUTCTime . zonedTimeToUTC++-- | Whether the given @dateTime@ is timezoned.+isZoned ::+ DateTime+ -> Bool+isZoned =+ isn't pLocalTime++-- | Whether the given @dateTime@ is non-timezoned.+isUnzoned ::+ DateTime+ -> Bool+isUnzoned =+ isn't pUTCTime++-- | Attempts to convert a @dateTime@ to a UTC time. The attempt fails+-- if the given @dateTime@ is non-timezoned.+toUTCTime ::+ DateTime+ -> Maybe UTCTime+toUTCTime =+ (^? pUTCTime)++-- | Converts a UTC time to a timezoned @dateTime@.+fromUTCTime ::+ UTCTime+ -> DateTime+fromUTCTime =+ (pUTCTime #)++-- | Attempts to convert a @dateTime@ to a local time. The attempt+-- fails if the given @dateTime@ is timezoned.+toLocalTime ::+ DateTime+ -> Maybe LocalTime+toLocalTime =+ (^? pLocalTime)++-- | Converts a local time to a non-timezoned @dateTime@.+fromLocalTime ::+ LocalTime+ -> DateTime+fromLocalTime =+ (pLocalTime #)++-- | Parses the string in a @dateTime@ then converts to a UTC time and+-- may fail with a parse error.+utcTime' ::+ Text+ -> Either String UTCTime+utcTime' txt =+ dateTime' txt >>= maybe (Left err) Right . toUTCTime+ where+ err = "input time is non-timezoned"++-- | Parses the string in a @dateTime@ then converts to a UTC time and+-- may fail.+utcTime ::+ Text+ -> Maybe UTCTime+utcTime txt =+ txt ^? dateTime >>= toUTCTime++-- | Parses the string in a @dateTime@ then converts to a local time+-- and may fail with a parse error.+localTime' ::+ Text+ -> Either String LocalTime+localTime' txt =+ dateTime' txt >>= maybe (Left err) Right . toLocalTime+ where+ err = "input time is non-timezoned"++-- | Parses the string in a @dateTime@ then converts to a local time+-- time and may fail.+localTime ::+ Text+ -> Maybe LocalTime+localTime txt =+ txt ^? dateTime >>= toLocalTime++-- | Parser of the @dateTime@ lexical representation.+parseDateTime ::+ Parser DateTime+parseDateTime =+ do yy <- yearParser+ _ <- char '-'+ mm <- p2imax 12+ _ <- char '-'+ dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm)+ _ <- char 'T'+ hhh <- p2imax 24+ _ <- char ':'+ mmm <- p2imax 59+ _ <- char ':'+ sss <- secondParser+ when (hhh == 24 && (mmm /= 0 || sss /= 0))+ $ fail "invalid time, past 24:00:00"+ o <- parseOffset+ return $ mkDateTime yy mm dd hhh mmm sss o++-- | Parse timezone offset.+parseOffset ::+ Parser (Maybe Pico)+parseOffset =+ (endOfInput *> pure Nothing)+ <|>+ (char 'Z' *> pure (Just 0))+ <|>+ (do sign <- (char '+' *> pure 1) <|> (char '-' *> pure (-1))+ hh <- fromIntegral <$> p2imax 14+ _ <- char ':'+ mm <- fromIntegral <$> p2imax (if hh == 14 then 0 else 59)+ return . Just $ sign * (hh * 3600 + mm * 60))++yearParser ::+ Parser Integer+yearParser =+ do sign <- (char '-' *> pure (-1)) <|> pure 1+ ds <- takeWhile isDigit+ when (length ds < 4)+ $ fail "need at least four digits in year"+ when (length ds > 4 && head ds == '0')+ $ fail "leading zero in year"+ let Right (absyear, _) = TR.decimal ds+ when (absyear == 0)+ $ fail "year zero disallowed"+ return $ sign * absyear++secondParser ::+ Parser Pico+secondParser =+ do d1 <- digit+ d2 <- digit+ frac <- readFrac <$> (char '.' *> takeWhile isDigit)+ <|> pure 0+ return (read [d1, d2] + frac)+ where+ readFrac ds = read $ '0' : '.' : unpack ds++p2imax ::+ Int+ -> Parser Int+p2imax m =+ do a <- digit+ b <- digit+ let n = 10 * val a + val b+ if n > m+ then fail $ "value " ++ show n ++ " exceeded maximum " ++ show m+ else return n+ where+ val c = ord c - ord '0'
+ test/doctests.hs view
@@ -0,0 +1,32 @@+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
− test/main.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Data.Time.Clock (UTCTime)-import Debug.Trace-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit hiding (Test)---import Test.QuickCheck ()-import qualified Data.Text as T-import Test.QuickCheck.Instances ()--import Text.XML.XSD--import DateTime--booleanTests :: Test-booleanTests = testGroup "Boolean"- $ parseTests ++ renderTests- where- mkParseTest (t, e) = testCase ("Parse " ++ T.unpack t)- (boolean t @?= Right e)- parseTests = map mkParseTest [ ("1", True)- , ("true", True)- , ("0", False)- , ("false", False)- ]- renderTests =- [ testCase "Render True" $ toBoolean True @?= "true"- , testCase "Render False" $ toBoolean False @?= "false"- ]--main :: IO ()-main = defaultMain [ booleanTests- , DateTime.tests- ]
xsd.cabal view
@@ -1,39 +1,70 @@-Name: xsd-Version: 0.4.0.1-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.8+name: xsd+version: 0.5.0.0+license: BSD3+license-file: LICENSE+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+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+cabal-version: >= 1.10+build-type: Custom+extra-source-files: ChangeLog -Library- Build-Depends: base < 5 && >= 4.5- , attoparsec- , text- , time >= 1.2.0.3- GHC-Options: -Wall- Exposed-Modules: Text.XML.XSD- Text.XML.XSD.DateTime+source-repository head+ type: git+ location: git@github.com:tonymorris/xsd.git -test-suite test- type: exitcode-stdio-1.0- main-is: main.hs- hs-source-dirs: . test- ghc-options: -rtsopts- build-depends: base- , bytestring- , time- , text- , attoparsec- , test-framework- , test-framework-hunit- , test-framework-quickcheck2- , QuickCheck == 2.*- , quickcheck-instances- , HUnit+flag small_base+ description: Choose the new, split-up base package.++library+ default-language:+ Haskell2010++ build-depends: base < 5 && >= 4.5+ , attoparsec >= 0.11+ , text >= 1.0+ , time >= 1.2.0.3+ , lens >= 4++ ghc-options:+ -Wall++ default-extensions:+ NoImplicitPrelude++ hs-source-dirs:+ src++ 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