[commit: packages/time] format-widths, ghc, improve-leapseconds, master, posix-perf, tasty, wip/travis: test for %y parse to 1969 - 2068 (ac3fc0b)

[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/ac3fc0bf4d197ed82fdd6dff4383a07d8766d433

>---------------------------------------------------------------

commit ac3fc0bf4d197ed82fdd6dff4383a07d8766d433
Author: Ashley Yakeley <ashley at semantic.org>
Date:   Sat May 7 21:22:16 2011 -0700

    test for %y parse to 1969 - 2068
    
    Ignore-this: ac903c931b2fe745f073a5cb474e9d95
    
    darcs-hash:20110508042216-ac6dd-e6e305e2cb3804511eefdd74dc4b558fcfd00f51


>---------------------------------------------------------------

ac3fc0bf4d197ed82fdd6dff4383a07d8766d433
 test/TestParseTime.hs | 54 ++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 43 insertions(+), 11 deletions(-)

diff --git a/test/TestParseTime.hs b/test/TestParseTime.hs
index 37d13f6..64a4504 100644
--- 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,49 @@ import Test.QuickCheck
 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)
-
-
-checkAll :: [NamedProperty] -> IO Bool
+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)
+
+extests :: [(String,ExhaustiveTest)]
+extests = [("parse %y",MkExhaustiveTest [0..99] parseYY)]
+
+-- | 1969 - 2068
+expectedYear :: Integer -> Integer
+expectedYear i | i >= 69 = 1900 + i
+expectedYear i = 2000 + i
+
+parseYY :: Integer -> IO Bool
+parseYY i = return (parse "%y" ((show (div i 10)) ++ (show (mod i 10))) == Just (fromGregorian (expectedYear i) 1 1))
+
+checkAll :: RunTest p => [(String,p)] -> IO Bool
 checkAll ps = fmap and (mapM checkOne ps)
 
 trMessage :: TestResult -> String
@@ -37,16 +70,15 @@ trGood :: TestResult -> Bool
 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