[commit: packages/time] master: fix parse "undefined" bug; added TestParseTime into tests (c5041a7)
git at git.haskell.org
git at git.haskell.org
Sun Dec 20 07:53:11 UTC 2015
Repository : ssh://git@git.haskell.org/time
On branch : master
Link : http://git.haskell.org/packages/time.git/commitdiff/c5041a75c0c4ac903d4b6aa8ce4494b3fd75138b
>---------------------------------------------------------------
commit c5041a75c0c4ac903d4b6aa8ce4494b3fd75138b
Author: Ashley Yakeley <ashley at semantic.org>
Date: Wed Feb 2 21:32:19 2011 -0800
fix parse "undefined" bug; added TestParseTime into tests
Ignore-this: aa74ebeef71272fda0a79962ed2e8f93
darcs-hash:20110203053219-ac6dd-38e9068fa7badb315aa19be8f1f77f75f06c03cc
>---------------------------------------------------------------
c5041a75c0c4ac903d4b6aa8ce4494b3fd75138b
Data/Time/Format.hs | 2 +-
Data/Time/Format/Parse.hs | 7 ++++--
Makefile | 2 +-
test/Makefile | 10 ++++----
test/TestFormat.hs | 59 +++++++++++++++++++++++++++++++++++++++++++++--
test/TestParseTime.hs | 42 +++++++++++++++++++++++----------
time.cabal | 2 +-
7 files changed, 99 insertions(+), 25 deletions(-)
diff --git a/Data/Time/Format.hs b/Data/Time/Format.hs
index 8d27f83..174bbea 100644
--- a/Data/Time/Format.hs
+++ b/Data/Time/Format.hs
@@ -55,7 +55,7 @@ formatChar c locale mpado t = case (formatCharacter c) of
--
-- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'):
--
--- [@%z@] timezone offset on the format @-HHMM at .
+-- [@%z@] timezone offset in the format @-HHMM at .
--
-- [@%Z@] timezone name
--
diff --git a/Data/Time/Format/Parse.hs b/Data/Time/Format/Parse.hs
index 4fd2282..aa0b66d 100644
--- a/Data/Time/Format/Parse.hs
+++ b/Data/Time/Format/Parse.hs
@@ -179,10 +179,13 @@ parseValue l c =
where
oneOf = choice . map string
digits n = count n (satisfy isDigit)
- spdigits n = skipSpaces >> upTo n (satisfy isDigit)
+ spdigits n = skipSpaces >> oneUpTo n (satisfy isDigit)
+ oneUpTo :: Int -> ReadP a -> ReadP [a]
+ oneUpTo 0 _ = pfail
+ oneUpTo n x = liftM2 (:) x (upTo (n-1) x)
upTo :: Int -> ReadP a -> ReadP [a]
upTo 0 _ = return []
- upTo n x = liftM2 (:) x (upTo (n-1) x) <++ return []
+ upTo n x = (oneUpTo n x) <++ return []
numericTZ = do s <- choice [char '+', char '-']
h <- digits 2
optional (char ':')
diff --git a/Makefile b/Makefile
index de4898f..a0b37a9 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-default: build
+default: install
# Building
diff --git a/test/Makefile b/test/Makefile
index f97252e..5c1487a 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -64,26 +64,27 @@ test: \
TestFormat.diff0 \
TestParseDAT.diff \
TestEaster.diff \
-# TestParseTime.run \
+ TestParseTime.run \
UseCases.o
@echo "Success!"
clean:
rm -rf TestMonthDay ConvertBack TestCalendars TestTime LongWeekYears ClipDates \
AddDays TestFormat TestParseDAT TestEaster CurrentTime ShowDST TimeZone TimeZone.ref TestParseTime \
- *.out *.o *.hi Makefile.bak
+ *.out *.run *.o *.hi Makefile.bak
%.diff: %.ref %.out
diff -u $^
%.diff0: %.out
- echo -n | diff -u - $^
+ diff -u /dev/null $^
%.out: %
./$< > $@
%.run: %
./$<
+ touch $@
%.hi: %.o
@:
@@ -98,6 +99,3 @@ FORCE:
.SECONDARY:
-# TestTime.o TestFormat.o CurrentTime.o ShowDST.o TimeZone.o: $(patsubst %.hs,%.hi,$(SRCS))
-
-TestFixed.o: ../Data/Fixed.hi
diff --git a/test/TestFormat.hs b/test/TestFormat.hs
index bcc18d4..65ca575 100644
--- a/test/TestFormat.hs
+++ b/test/TestFormat.hs
@@ -9,6 +9,7 @@ import Data.Char
import System.Locale
import Foreign
import Foreign.C
+import Control.Exception;
{-
size_t format_time (
@@ -93,9 +94,63 @@ formats = ["%G-W%V-%u","%U-%w","%W-%u"] ++ (fmap (\char -> '%':char:[]) chars)
hashformats :: [String]
hashformats = (fmap (\char -> '%':'#':char:[]) chars)
+somestrings :: [String]
+somestrings = ["", " ", "-", "\n"]
+
+getBottom :: a -> IO (Maybe Control.Exception.SomeException);
+getBottom a = Control.Exception.catch (seq a (return Nothing)) (return . Just);
+
+safeString :: String -> IO String
+safeString s = do
+ msx <- getBottom s
+ case msx of
+ Just sx -> return (show sx)
+ Nothing -> case s of
+ (c:cc) -> do
+ mcx <- getBottom c
+ case mcx of
+ Just cx -> return (show cx)
+ Nothing -> do
+ ss <- safeString cc
+ return (c:ss)
+ [] -> return ""
+
+compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> IO ()
+compareExpected ts fmt str expected = let
+ found = parseTime defaultTimeLocale fmt str
+ in do
+ mex <- getBottom found
+ case mex of
+ Just ex -> putStrLn ("Exception with " ++ fmt ++ " for " ++ ts ++" " ++ (show str) ++ ": expected " ++ (show expected) ++ ", caught " ++ (show ex))
+ Nothing -> if found == expected
+ then return ()
+ else do
+ sf <- safeString (show found)
+ putStrLn ("Mismatch with " ++ fmt ++ " for " ++ ts ++" " ++ (show str) ++ ": expected " ++ (show expected) ++ ", found " ++ sf)
+
+class (ParseTime t) => TestParse t where
+ expectedParse :: String -> String -> Maybe t
+ expectedParse "%Z" str | all isSpace str = Just (buildTime defaultTimeLocale [])
+ expectedParse _ _ = Nothing
+
+instance TestParse Day
+instance TestParse TimeOfDay
+instance TestParse LocalTime
+instance TestParse TimeZone
+instance TestParse ZonedTime
+instance TestParse UTCTime
+
+checkParse :: String -> String -> IO ()
+checkParse fmt str = do
+ compareExpected "Day" fmt str (expectedParse fmt str :: Maybe Day)
+ compareExpected "TimeOfDay" fmt str (expectedParse fmt str :: Maybe TimeOfDay)
+ compareExpected "LocalTime" fmt str (expectedParse fmt str :: Maybe LocalTime)
+ compareExpected "TimeZone" fmt str (expectedParse fmt str :: Maybe TimeZone)
+ compareExpected "UTCTime" fmt str (expectedParse fmt str :: Maybe UTCTime)
main :: IO ()
-main =
- mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat id fmt zone time) zones) times) formats >>
+main = do
+ mapM_ (\fmt -> mapM_ (checkParse fmt) somestrings) formats
+ mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat id fmt zone time) zones) times) formats
mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat (fmap toLower) fmt zone time) zones) times) hashformats
diff --git a/test/TestParseTime.hs b/test/TestParseTime.hs
index b727f3f..37d13f6 100644
--- a/test/TestParseTime.hs
+++ b/test/TestParseTime.hs
@@ -8,7 +8,9 @@ import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Clock.POSIX
import System.Locale
+import System.Exit
import Test.QuickCheck
+import Test.QuickCheck.Batch
ntest :: Int
@@ -16,19 +18,35 @@ ntest = 1000
main :: IO ()
main = do putStrLn "Should work:"
- checkAll properties
+ good <- checkAll properties
putStrLn "Known failures:"
- checkAll knownFailures
-
-checkAll :: [NamedProperty] -> IO ()
-checkAll ps = mapM_ (checkOne config) ps
- where config = defaultConfig { configMaxTest = ntest }
-
-checkOne :: Config -> NamedProperty -> IO ()
-checkOne config (n,p) =
- do putStr (rpad 65 ' ' n)
- check config p
- where rpad n' c xs = xs ++ replicate (n' - length xs) c
+ _ <- checkAll knownFailures
+ exitWith (if good then ExitSuccess else ExitFailure 1)
+
+
+checkAll :: [NamedProperty] -> IO Bool
+checkAll ps = fmap and (mapM checkOne ps)
+
+trMessage :: TestResult -> String
+trMessage (TestOk s _ _) = s
+trMessage (TestExausted s i ss) = "Exhausted " ++ (show s) ++ " " ++ (show i) ++ " " ++ (show ss)
+trMessage (TestFailed ss i) = "Failed " ++ (show ss) ++ " " ++ (show i)
+trMessage (TestAborted ex) = "Aborted " ++ (show ex)
+
+trGood :: TestResult -> Bool
+trGood (TestOk _ _ _) = True
+trGood _ = False
+
+checkOne :: NamedProperty -> IO Bool
+checkOne (n,p) =
+ do
+ putStr (rpad 65 ' ' n)
+ tr <- run p options
+ 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/time.cabal b/time.cabal
index 3f88c02..2759127 100644
--- a/time.cabal
+++ b/time.cabal
@@ -1,5 +1,5 @@
name: time
-version: 1.2.0.3
+version: 1.2.0.4
stability: stable
license: BSD3
license-file: LICENSE
More information about the ghc-commits
mailing list