diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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) diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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} diff --git a/Text/XML/XSD.hs b/Text/XML/XSD.hs deleted file mode 100644 --- a/Text/XML/XSD.hs +++ /dev/null @@ -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 diff --git a/Text/XML/XSD/DateTime.hs b/Text/XML/XSD/DateTime.hs deleted file mode 100644 --- a/Text/XML/XSD/DateTime.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | XSD @dateTime@ data structure -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 --- . 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' diff --git a/src/Text/XML/XSD.hs b/src/Text/XML/XSD.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/XSD.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE EmptyDataDecls #-} + +module Text.XML.XSD + ( E18 + , Atto + , boolean + , toBoolean + , decimal + , integer + , toSigned + , long + , int + , short + , byte + , unsignedInteger + , unsignedLong + , unsignedInt + , unsignedShort + , unsignedByte + , float + , double + , fastDouble + , module Text.XML.XSD.DateTime + ) where + +import Text.XML.XSD.DateTime + +import Prelude(String, Double, Float, Integral, Eq(..), (||), otherwise) +import Control.Monad (Monad(..), when) +import Data.Bool(Bool(..)) +import Data.Fixed (Fixed, HasResolution(..), resolution) +import Data.Either(Either(..)) +import Data.Function((.), ($)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List((++)) +import Data.Text (Text, unpack) +import Data.Text.Lazy(toStrict) +import Data.Text.Lazy.Builder(toLazyText) +import qualified Data.Text.Lazy.Builder.Int as TBI(decimal) +import qualified Data.Text.Read as TR(rational, double, decimal, signed) +import Data.Word (Word8, Word16, Word32, Word64) + +data E18 + +instance HasResolution E18 where + resolution _ = 1000000000000000000 + +type Atto = Fixed E18 + +checkReader :: Either String (a, Text) -> Either String a +checkReader res = + do (val, t) <- res + when (t /= "") $ Left "leftovers" + return val + +-- checkReader (Left msg) = Left msg +-- checkReader (Right (val, t)) +-- | t /= "" = Left "leftovers" +-- | otherwise = Right val + +boolean :: Text -> Either String Bool +boolean t + | t == "true" || t == "1" = Right True + | t == "false" || t == "0" = Right False + | otherwise = Left $ "invalid boolean '" ++ unpack t ++ "'" + +toBoolean :: Bool -> Text +toBoolean True = "true" +toBoolean False = "false" + +decimal :: Text -> Either String Atto +decimal = checkReader . TR.rational + +signed :: Integral a => Text -> Either String a +signed = checkReader . TR.signed TR.decimal + +unsigned :: Integral a => Text -> Either String a +unsigned = checkReader . TR.decimal + +toSigned :: Integral a => a -> Text +toSigned = toStrict . toLazyText . TBI.decimal + +integer :: Integral a => Text -> Either String a +integer = signed + +long :: Text -> Either String Int64 +long = signed + +int :: Text -> Either String Int32 +int = signed + +short :: Text -> Either String Int16 +short = signed + +byte :: Text -> Either String Int8 +byte = signed + +-- | What XSD calls @nonNegativeInteger@. +unsignedInteger :: Integral a => Text -> Either String a +unsignedInteger = unsigned + +unsignedLong :: Text -> Either String Word64 +unsignedLong = unsigned + +unsignedInt :: Text -> Either String Word32 +unsignedInt = unsigned + +unsignedShort :: Text -> Either String Word16 +unsignedShort = unsigned + +unsignedByte :: Text -> Either String Word8 +unsignedByte = unsigned + +float :: Text -> Either String Float +float = checkReader . TR.rational + +double :: Text -> Either String Double +double = checkReader . TR.rational + +fastDouble :: Text -> Either String Double +fastDouble = checkReader . TR.double diff --git a/src/Text/XML/XSD/DateTime.hs b/src/Text/XML/XSD/DateTime.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/XSD/DateTime.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | XSD @dateTime@ data structure +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 +-- . 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' diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -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 diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -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 - ] diff --git a/xsd.cabal b/xsd.cabal --- a/xsd.cabal +++ b/xsd.cabal @@ -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 -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 , 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