xsd 0.3.7 → 0.4.0
raw patch · 4 files changed
+373/−160 lines, 4 filesdep +HUnitdep +QuickCheckdep +attoparsecdep −parsecdep ~basedep ~time
Dependencies added: HUnit, QuickCheck, attoparsec, bytestring, quickcheck-instances, test-framework, test-framework-hunit, test-framework-quickcheck2, text
Dependencies removed: parsec
Dependency ranges changed: base, time
Files
- Text/XML/XSD.hs +119/−4
- Text/XML/XSD/DateTime.hs +192/−145
- test/main.hs +38/−0
- xsd.cabal +24/−11
Text/XML/XSD.hs view
@@ -1,5 +1,120 @@-module Text.XML.XSD(- module Text.XML.XSD.DateTime- ) where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE EmptyDataDecls #-} -import Text.XML.XSD.DateTime+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 view
@@ -1,187 +1,234 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | 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+module Text.XML.XSD.DateTime+ ( DateTime(..)+ , isZoned+ , isUnzoned+ , dateTime'+ , dateTime+ , toText+ , fromZonedTime+ , toUTCTime+ , fromUTCTime+ , toLocalTime+ , fromLocalTime+ , utcTime'+ , utcTime+ , localTime'+ , localTime+ ) 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+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>-data DateTime = DateTime Bool Int Int Int Int Int Int (Maybe String) Offset+-- | 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) -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+-- | 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 (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]+ show = T.unpack . toText 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)+ readList s = [(maybeToList (dateTime . T.pack $ s), [])] -- | Parses the string into a @dateTime@ or may fail with a parse error.-dateTime' :: String -> Either ParseError DateTime-dateTime' = parse parseDateTime "DateTime parser"+dateTime' :: Text -> Either String DateTime+dateTime' = A.parseOnly (parseDateTime <|> fail "bad date time") -- | Parses the string into a @dateTime@ or may fail.-dateTime :: String -> Maybe DateTime+dateTime :: Text -> 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))+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 --- | 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'+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 --- | Parses the string in a @dateTime@ then converts to a zoned time and may fail.-zonedTime :: String -> Maybe ZonedTime-zonedTime = fmap toZonedTime . dateTime+buildUInt2 :: Int -> TB.Builder+buildUInt2 x = (if x < 10 then ("0" <>) else id) $ TBI.decimal x --- | Converts a @dateTime@ to a UTC time.-toUTCTime :: DateTime -> UTCTime-toUTCTime = uncurry localTimeToUTC . (zonedTimeZone &&& zonedTimeToLocalTime) . toZonedTime+buildSeconds :: Pico -> TB.Builder+buildSeconds secs = (if secs < 10 then ("0" <>) else id)+ $ TB.fromString (showFixed True secs) --- | 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)+-- | Converts a zoned time to a @dateTime@.+fromZonedTime :: ZonedTime -> DateTime+fromZonedTime = fromUTCTime . zonedTimeToUTC --- | 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'+-- | Whether the given @dateTime@ is timezoned.+isZoned :: DateTime -> Bool+isZoned (DtZoned _) = True+isZoned (DtUnzoned _) = False --- | Parses the string in a @dateTime@ then converts to a UTC time and may fail.-utcTime :: String -> Maybe UTCTime-utcTime = fmap toUTCTime . dateTime+-- | Whether the given @dateTime@ is non-timezoned.+isUnzoned :: DateTime -> Bool+isUnzoned = not . isZoned --- not exported+-- | 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 -data Offset = Offset Bool (Maybe Bool) (Maybe Int) (Maybe Int)- deriving Eq+-- | Converts a UTC time to a timezoned @dateTime@.+fromUTCTime :: UTCTime -> DateTime+fromUTCTime = DtZoned -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"+-- | 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 -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"+-- | Converts a local time to an non-timezoned @dateTime@.+fromLocalTime :: LocalTime -> DateTime+fromLocalTime = DtUnzoned -seconds :: Maybe String -> String-seconds (Just s) =- case s of- "" -> []- _ -> '.' : s-seconds Nothing = []+-- | 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" -showi :: (Show a, Num a, Ord a) => a -> String-showi n = (if n < 10 then ('0':) else id) (show n)+-- | Parses the string in a @dateTime@ then converts to a UTC time and+-- may fail.+utcTime :: Text -> Maybe UTCTime+utcTime txt = dateTime txt >>= toUTCTime -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)))+-- | 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" -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+-- | 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 -parseDateTime :: GenParser Char st DateTime-parseDateTime = do neg <- isJust `fmap` optionMaybe (char '-')- yy <- yearParser+-- | Parser of the @dateTime@ lexical representation.+parseDateTime :: Parser DateTime+parseDateTime = do 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))+ dd <- p2imax (monthLength (isLeapYear $ fromIntegral yy) mm) _ <- char 'T'- hhh <- p2imax 23+ hhh <- p2imax 24 _ <- char ':' mmm <- p2imax 59 _ <- char ':'- sss <- p2imax 59- ssss <- optionMaybe fractionalSeconds+ sss <- secondParser+ when (hhh == 24 && (mmm /= 0 || sss /= 0))+ $ fail "invalid time, past 24:00:00" o <- parseOffset- return (dateTimeConstr neg yy mm dd hhh mmm sss ssss o)+ return $ mkDateTime yy mm dd hhh mmm sss 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))+-- | 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)) -fractionalSeconds :: GenParser Char st String-fractionalSeconds = do _ <- char '.'- many1 digit+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 -p2imax :: Int -> GenParser Char st Int+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 = 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+ 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/main.hs view
@@ -0,0 +1,38 @@+{-# 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,5 +1,5 @@ Name: xsd-Version: 0.3.7+Version: 0.4.0 License: BSD3 License-File: LICENSE Synopsis: XML Schema data structures@@ -10,17 +10,30 @@ Maintainer: Stefan Wehr <wehr@factisresearch.com> Copyright: 2010 Tony Morris, 2013 Stefan Wehr build-type: Simple-cabal-version: >= 1.2--Flag small_base- Description: Choose the new, split-up base package.+cabal-version: >= 1.8 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-- GHC-Options: -Wall+ Build-Depends: base < 5 && >= 4.5+ , attoparsec == 0.10.*+ , text == 0.11.*+ , time >= 1.2.0.3+ GHC-Options: -Wall Exposed-Modules: Text.XML.XSD Text.XML.XSD.DateTime++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