[commit: packages/time] format-widths,ghc,improve-leapseconds,master,posix-perf,tasty,wip/travis: fix parse "undefined" bug; added TestParseTime into tests (c5041a7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/time

On branches: format-widths,ghc,improve-leapseconds,master,posix-perf,tasty,wip/travis
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