diff --git a/Data/Time/Format/Parse.hs b/Data/Time/Format/Parse.hs --- a/Data/Time/Format/Parse.hs +++ b/Data/Time/Format/Parse.hs @@ -55,20 +55,21 @@ -- If the input does not include all the information needed to -- construct a complete value, any missing parts should be taken -- from 1970-01-01 00:00:00 +0000 (which was a Thursday). + -- In the absence of @%C@ or @%Y@, century is 1969 - 2068. buildTime :: TimeLocale -- ^ The time locale. -> [(Char,String)] -- ^ Pairs of format characters and the -- corresponding part of the input. -> t #if LANGUAGE_Rank2Types --- | Parses a time value given a format string. Supports the same %-codes as --- 'formatTime'. Leading and trailing whitespace is accepted. Case is not --- significant. Some variations in the input are accepted: +-- | Parses a time value given a format string. +-- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers. +-- Leading and trailing whitespace is accepted. Case is not significant. +-- Some variations in the input are accepted: -- -- [@%z@] accepts any of @-HHMM@ or @-HH:MM@. -- --- [@%Z@] accepts any string of letters, or any --- of the formats accepted by @%z@. +-- [@%Z@] accepts any string of letters, or any of the formats accepted by @%z@. -- parseTime :: ParseTime t => TimeLocale -- ^ Time locale. @@ -104,9 +105,12 @@ -- * Internals -- +data Padding = NoPadding | SpacePadding | ZeroPadding + deriving Show + type DateFormat = [DateFormatSpec] -data DateFormatSpec = Value Char +data DateFormatSpec = Value (Maybe Padding) Char | WhiteSpace | Literal Char deriving Show @@ -114,31 +118,33 @@ parseFormat :: TimeLocale -> String -> DateFormat parseFormat l = p where p "" = [] - p ('%': c :cs) = s ++ p cs - where s = case c of - 'c' -> p (dateTimeFmt l) - 'R' -> p "%H:%M" - 'T' -> p "%H:%M:%S" - 'X' -> p (timeFmt l) - 'r' -> p (time12Fmt l) - 'D' -> p "%m/%d/%y" - 'F' -> p "%Y-%m-%d" - 'x' -> p (dateFmt l) - 'h' -> p "%b" - '%' -> [Literal '%'] - _ -> [Value c] + p ('%': '-' : c :cs) = (pc (Just NoPadding) c) ++ p cs + p ('%': '_' : c :cs) = (pc (Just SpacePadding) c) ++ p cs + p ('%': '0' : c :cs) = (pc (Just ZeroPadding) c) ++ p cs + p ('%': c :cs) = (pc Nothing c) ++ p cs p (c:cs) | isSpace c = WhiteSpace : p cs p (c:cs) = Literal c : p cs + pc _ 'c' = p (dateTimeFmt l) + pc _ 'R' = p "%H:%M" + pc _ 'T' = p "%H:%M:%S" + pc _ 'X' = p (timeFmt l) + pc _ 'r' = p (time12Fmt l) + pc _ 'D' = p "%m/%d/%y" + pc _ 'F' = p "%Y-%m-%d" + pc _ 'x' = p (dateFmt l) + pc _ 'h' = p "%b" + pc _ '%' = [Literal '%'] + pc mpad c = [Value mpad c] parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)] parseInput l = liftM catMaybes . mapM p - where p (Value c) = parseValue l c >>= return . Just . (,) c + where p (Value mpad c) = parseValue l mpad c >>= return . Just . (,) c p WhiteSpace = skipSpaces >> return Nothing p (Literal c) = char c >> return Nothing -- | Get the string corresponding to the given format specifier. -parseValue :: TimeLocale -> Char -> ReadP String -parseValue l c = +parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String +parseValue l mpad c = case c of 'z' -> numericTZ 'Z' -> munch1 isAlpha <++ @@ -146,40 +152,42 @@ return "" -- produced by %Z for LocalTime 'P' -> oneOf (let (am,pm) = amPm l in [am, pm]) 'p' -> oneOf (let (am,pm) = amPm l in [am, pm]) - 'H' -> digits 2 - 'I' -> digits 2 - 'k' -> spdigits 2 - 'l' -> spdigits 2 - 'M' -> digits 2 - 'S' -> digits 2 - 'q' -> digits 12 + 'H' -> digits ZeroPadding 2 + 'I' -> digits ZeroPadding 2 + 'k' -> digits SpacePadding 2 + 'l' -> digits SpacePadding 2 + 'M' -> digits ZeroPadding 2 + 'S' -> digits ZeroPadding 2 + 'q' -> digits ZeroPadding 12 'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return "" 's' -> (char '-' >> liftM ('-':) (munch1 isDigit)) <++ munch1 isDigit - 'Y' -> digits 4 - 'y' -> digits 2 - 'C' -> digits 2 + 'Y' -> digits ZeroPadding 4 + 'y' -> digits ZeroPadding 2 + 'C' -> digits ZeroPadding 2 'B' -> oneOf (map fst (months l)) 'b' -> oneOf (map snd (months l)) - 'm' -> digits 2 - 'd' -> digits 2 - 'e' -> spdigits 2 - 'j' -> digits 3 - 'G' -> digits 4 - 'g' -> digits 2 - 'f' -> digits 2 - 'V' -> digits 2 + 'm' -> digits ZeroPadding 2 + 'd' -> digits ZeroPadding 2 + 'e' -> digits SpacePadding 2 + 'j' -> digits ZeroPadding 3 + 'G' -> digits ZeroPadding 4 + 'g' -> digits ZeroPadding 2 + 'f' -> digits ZeroPadding 2 + 'V' -> digits ZeroPadding 2 'u' -> oneOf $ map (:[]) ['1'..'7'] 'a' -> oneOf (map snd (wDays l)) 'A' -> oneOf (map fst (wDays l)) - 'U' -> digits 2 + 'U' -> digits ZeroPadding 2 'w' -> oneOf $ map (:[]) ['0'..'6'] - 'W' -> digits 2 + 'W' -> digits ZeroPadding 2 _ -> fail $ "Unknown format character: " ++ show c where oneOf = choice . map string - digits n = count n (satisfy isDigit) - spdigits n = skipSpaces >> oneUpTo n (satisfy isDigit) + digitsforce ZeroPadding n = count n (satisfy isDigit) + digitsforce SpacePadding n = skipSpaces >> oneUpTo n (satisfy isDigit) + digitsforce NoPadding n = oneUpTo n (satisfy isDigit) + digits pad = digitsforce (fromMaybe pad mpad) oneUpTo :: Int -> ReadP a -> ReadP [a] oneUpTo 0 _ = pfail oneUpTo n x = liftM2 (:) x (upTo (n-1) x) @@ -187,9 +195,9 @@ upTo 0 _ = return [] upTo n x = (oneUpTo n x) <++ return [] numericTZ = do s <- choice [char '+', char '-'] - h <- digits 2 + h <- digitsforce ZeroPadding 2 optional (char ':') - m <- digits 2 + m <- digitsforce ZeroPadding 2 return (s:h++m) #endif @@ -254,8 +262,9 @@ buildDay cs = rest cs where - y = let c = safeLast 19 [x | Century x <- cs] + y = let d = safeLast 70 [x | Year x <- cs] + c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] in 100 * c + d rest (Month m:_) = let d = safeLast 1 [x | Day x <- cs] diff --git a/test/Makefile b/test/Makefile --- a/test/Makefile +++ b/test/Makefile @@ -1,5 +1,5 @@ GHC = ghc -GHCFLAGS = -package time +GHCFLAGS = -package time -package QuickCheck-1.2.0.1 default: make CurrentTime.run ShowDST.run test @@ -50,7 +50,7 @@ date +%z > $@ TestParseTime: TestParseTime.o - $(GHC) $(GHCFLAGS) -package QuickCheck $^ -o $@ + $(GHC) $(GHCFLAGS) $^ -o $@ test: \ TestMonthDay.diff \ diff --git a/test/TestFormat.hs b/test/TestFormat.hs --- a/test/TestFormat.hs +++ b/test/TestFormat.hs @@ -131,6 +131,9 @@ class (ParseTime t) => TestParse t where expectedParse :: String -> String -> Maybe t expectedParse "%Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%_Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%-Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%0Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) expectedParse _ _ = Nothing instance TestParse Day diff --git a/test/TestParseTime.hs b/test/TestParseTime.hs --- a/test/TestParseTime.hs +++ b/test/TestParseTime.hs @@ -1,8 +1,10 @@ {-# OPTIONS -Wall -Werror -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, ExistentialQuantification #-} import Control.Monad import Data.Char import Data.Ratio +import Data.Maybe import Data.Time import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate @@ -13,18 +15,79 @@ import Test.QuickCheck.Batch +class RunTest p where + runTest :: p -> IO TestResult + +instance RunTest (IO TestResult) where + runTest iob = iob + +instance RunTest Property where + runTest p = run p (TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False}) + +data ExhaustiveTest = forall t. (Show t) => MkExhaustiveTest [t] (t -> IO Bool) + +instance RunTest ExhaustiveTest where + runTest (MkExhaustiveTest cases f) = do + results <- mapM (\t -> do {b <- f t;return (b,show t)}) cases + let failures = mapMaybe (\(b,n) -> if b then Nothing else Just n) results + let fcount = length failures + return (if fcount == 0 then TestOk "OK" 0 [] else TestFailed failures fcount) + ntest :: Int ntest = 1000 main :: IO () -main = do putStrLn "Should work:" - good <- checkAll properties - putStrLn "Known failures:" - _ <- checkAll knownFailures - exitWith (if good then ExitSuccess else ExitFailure 1) +main = do + putStrLn "Should work:" + good1 <- checkAll extests + putStrLn "Should work:" + good2 <- checkAll properties + putStrLn "Known failures:" + _ <- checkAll knownFailures + exitWith (if good1 && good2 then ExitSuccess else ExitFailure 1) +days2011 :: [Day] +days2011 = [(fromGregorian 2011 1 1) .. (fromGregorian 2011 12 31)] -checkAll :: [NamedProperty] -> IO Bool +extests :: [(String,ExhaustiveTest)] +extests = [ + ("parse %y",MkExhaustiveTest [0..99] parseYY), + ("parse %C %y 1900s",MkExhaustiveTest [0..99] (parseCYY 19)), + ("parse %C %y 2000s",MkExhaustiveTest [0..99] (parseCYY 20)), + ("parse %C %y 1400s",MkExhaustiveTest [0..99] (parseCYY 14)), + ("parse %C %y 700s",MkExhaustiveTest [0..99] (parseCYY 7)), + ("parse %Y%m%d",MkExhaustiveTest days2011 parseYMD), + ("parse %Y %m %d",MkExhaustiveTest days2011 parseYearDayD), + ("parse %Y %-m %e",MkExhaustiveTest days2011 parseYearDayE) + ] + +parseYMD :: Day -> IO Bool +parseYMD day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d))) == Just day + +parseYearDayD :: Day -> IO Bool +parseYearDayD day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d))) == Just day + +parseYearDayE :: Day -> IO Bool +parseYearDayE day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d))) == Just day + +-- | 1969 - 2068 +expectedYear :: Integer -> Integer +expectedYear i | i >= 69 = 1900 + i +expectedYear i = 2000 + i + +show2 :: (Integral n) => n -> String +show2 i = (show (div i 10)) ++ (show (mod i 10)) + +parseYY :: Integer -> IO Bool +parseYY i = return (parse "%y" (show2 i) == Just (fromGregorian (expectedYear i) 1 1)) + +parseCYY :: Integer -> Integer -> IO Bool +parseCYY c i = return (parse "%C %y" ((show2 c) ++ " " ++ (show2 i)) == Just (fromGregorian ((c * 100) + i) 1 1)) + +checkAll :: RunTest p => [(String,p)] -> IO Bool checkAll ps = fmap and (mapM checkOne ps) trMessage :: TestResult -> String @@ -37,16 +100,15 @@ trGood (TestOk _ _ _) = True trGood _ = False -checkOne :: NamedProperty -> IO Bool +checkOne :: RunTest p => (String,p) -> IO Bool checkOne (n,p) = do putStr (rpad 65 ' ' n) - tr <- run p options + tr <- runTest p putStrLn (trMessage tr) return (trGood tr) where rpad n' c xs = xs ++ replicate (n' - length xs) c - options = TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False} parse :: ParseTime t => String -> String -> Maybe t diff --git a/test/TimeZone.ref b/test/TimeZone.ref --- a/test/TimeZone.ref +++ b/test/TimeZone.ref @@ -1,1 +1,1 @@ --0800 +-0700 diff --git a/time.cabal b/time.cabal --- a/time.cabal +++ b/time.cabal @@ -1,5 +1,5 @@ name: time -version: 1.2.0.4 +version: 1.2.0.5 stability: stable license: BSD3 license-file: LICENSE