[commit: packages/time] format-widths: test: unix: Format: use QuickCheck (dd86365)

[git at git.haskell.org]

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

On branch  : format-widths
Link       : http://git.haskell.org/packages/time.git/commitdiff/dd86365d69a8f0caff9e31e9e9f31d70c5c3f359

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

commit dd86365d69a8f0caff9e31e9e9f31d70c5c3f359
Author: Ashley Yakeley <ashley at yakeley.org>
Date:   Sun Feb 5 23:15:38 2017 -0800

    test: unix: Format: use QuickCheck


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

dd86365d69a8f0caff9e31e9e9f31d70c5c3f359
 test/unix/Test/Format/Format.hs | 96 +++++++++++++++++++----------------------
 test/unix/Test/TestUtil.hs      | 10 ++++-
 2 files changed, 53 insertions(+), 53 deletions(-)

diff --git a/test/unix/Test/Format/Format.hs b/test/unix/Test/Format/Format.hs
index 02c8b33..420a70a 100644
--- a/test/unix/Test/Format/Format.hs
+++ b/test/unix/Test/Format/Format.hs
@@ -7,9 +7,11 @@ import Data.Time.Clock.POSIX
 import Data.Char
 import Foreign
 import Foreign.C
+import Test.QuickCheck hiding (Result)
+import Test.QuickCheck.Property
 import Test.Tasty
-import Test.Tasty.HUnit
 import Test.TestUtil
+import System.IO.Unsafe
 
 {-
     size_t format_time (
@@ -26,8 +28,8 @@ withBuffer n f = withArray (replicate n 0) (\buffer -> do
             peekCStringLen (buffer,fromIntegral len)
         )
 
-unixFormatTime :: String -> TimeZone -> UTCTime -> IO String
-unixFormatTime fmt zone time = withCString fmt (\pfmt -> withCString (timeZoneName zone) (\pzonename ->
+unixFormatTime :: String -> TimeZone -> UTCTime -> String
+unixFormatTime fmt zone time = unsafePerformIO $ withCString fmt (\pfmt -> withCString (timeZoneName zone) (\pzonename ->
         withBuffer 100 (\buffer -> format_time buffer 100 pfmt
                 (if timeZoneSummerOnly zone then 1 else 0)
                 (fromIntegral (timeZoneMinutes zone * 60))
@@ -39,36 +41,18 @@ unixFormatTime fmt zone time = withCString fmt (\pfmt -> withCString (timeZoneNa
 locale :: TimeLocale
 locale = defaultTimeLocale {dateTimeFmt = "%a %b %e %H:%M:%S %Y"}
 
-zones :: [TimeZone]
-zones = [utc,TimeZone 87 True "Fenwickian Daylight Time"]
+zones :: Gen TimeZone
+zones = do
+    mins <- choose (-2000,2000)
+    dst <- arbitrary
+    name <- return "ZONE"
+    return $ TimeZone mins dst name
 
-baseTime0 :: UTCTime
-baseTime0 = localTimeToUTC utc (LocalTime (fromGregorian 1970 01 01) midnight)
-
-baseTime1 :: UTCTime
-baseTime1 = localTimeToUTC utc (LocalTime (fromGregorian 2000 01 01) midnight)
-
-getDay :: Integer -> UTCTime
-getDay day = addUTCTime ((fromInteger day) * nominalDay) baseTime1
-
-getYearP1 :: Integer -> UTCTime
-getYearP1 year = localTimeToUTC utc (LocalTime (fromGregorian year 01 01) midnight)
-
-getYearP2 :: Integer -> UTCTime
-getYearP2 year = localTimeToUTC utc (LocalTime (fromGregorian year 02 04) midnight)
-
-getYearP3 :: Integer -> UTCTime
-getYearP3 year = localTimeToUTC utc (LocalTime (fromGregorian year 03 04) midnight)
-
-getYearP4 :: Integer -> UTCTime
-getYearP4 year = localTimeToUTC utc (LocalTime (fromGregorian year 12 31) midnight)
-
-years :: [Integer]
-years = [999,1000,1899,1900,1901] ++ [1980..2000] ++ [9999,10000]
-
-times :: [UTCTime]
-times = [baseTime0] ++ (fmap getDay [0..23]) ++ (fmap getDay [0..100]) ++
-    (fmap getYearP1 years) ++ (fmap getYearP2 years) ++ (fmap getYearP3 years) ++ (fmap getYearP4 years)
+times :: Gen UTCTime
+times = do
+    day <- choose (-25000,75000)
+    time <- return midnight
+    return $ localTimeToUTC utc $ LocalTime (ModifiedJulianDay day) time
 
 padN :: Int -> Char -> String -> String
 padN n _ s | n <= (length s) = s
@@ -85,14 +69,13 @@ unixWorkarounds "%_f" s = padN 2 ' ' s
 unixWorkarounds "%0f" s = padN 2 '0' s
 unixWorkarounds _ s = s
 
-compareFormat :: (String -> String) -> String -> TimeZone -> UTCTime -> Assertion
+compareFormat :: (String -> String) -> String -> TimeZone -> UTCTime -> Result
 compareFormat modUnix fmt zone time = let
     ctime = utcToZonedTime zone time
     haskellText = formatTime locale fmt ctime
-    in do
-       unixText <- unixFormatTime fmt zone time
-       let expectedText = unixWorkarounds fmt (modUnix unixText)
-       assertEqual "" expectedText haskellText
+    unixText = unixFormatTime fmt zone time
+    expectedText = unixWorkarounds fmt (modUnix unixText)
+    in assertEqualQC "" expectedText haskellText
 
 -- as found in http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html
 -- plus FgGklz
@@ -103,24 +86,33 @@ chars :: [Char]
 chars = "aAbBcCdDeFgGhHIjklmMnprRStTuUVwWxXyYzZ%"
 
 -- as found in "man strftime" on a glibc system. '#' is different, though
-modifiers :: [Char]
-modifiers = "_-0^"
+modifiers :: [String]
+modifiers = ["","_","-","0","^"]
 
 formats :: [String]
-formats =  ["%G-W%V-%u","%U-%w","%W-%u"] ++ (fmap (\char -> '%':char:[]) chars)
- ++ (concat (fmap (\char -> fmap (\modifier -> '%':modifier:char:[]) modifiers) chars))
+formats =  ["%G-W%V-%u","%U-%w","%W-%u"]
+ ++ (do
+    char <- chars
+    modifier <- modifiers
+    return $ "%" ++ modifier ++ [char]
+    )
 
 hashformats :: [String]
-hashformats =  (fmap (\char -> '%':'#':char:[]) chars)
-
-testCompareFormat :: TestTree
-testCompareFormat = testGroup "compare format" $ tgroup formats $ \fmt -> tgroup times $ \time -> tgroup zones $ \zone -> compareFormat id fmt zone time
-
-testCompareHashFormat :: TestTree
-testCompareHashFormat = testGroup "compare hashformat" $ tgroup hashformats $ \fmt -> tgroup times $ \time -> tgroup zones $ \zone -> compareFormat (fmap toLower) fmt zone time
+hashformats = do
+    char <- chars
+    return $ "%#"++[char]
+
+testCompareFormat :: [TestTree]
+testCompareFormat = tgroup formats $ \fmt -> do
+    time <- times
+    zone <- zones
+    return $ compareFormat id fmt zone time
+
+testCompareHashFormat :: [TestTree]
+testCompareHashFormat = tgroup hashformats $ \fmt -> do
+    time <- times
+    zone <- zones
+    return $ compareFormat (fmap toLower) fmt zone time
 
 testFormat :: TestTree
-testFormat = testGroup "testFormat" $ [
-    testCompareFormat,
-    testCompareHashFormat
-    ]
+testFormat = testGroup "testFormat" $ testCompareFormat ++ testCompareHashFormat
diff --git a/test/unix/Test/TestUtil.hs b/test/unix/Test/TestUtil.hs
index c306893..4a3b42d 100644
--- a/test/unix/Test/TestUtil.hs
+++ b/test/unix/Test/TestUtil.hs
@@ -4,7 +4,7 @@ module Test.TestUtil where
 import Test.QuickCheck.Property
 import Test.Tasty
 import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
+import Test.Tasty.QuickCheck hiding (reason)
 
 assertFailure' :: String -> IO a
 assertFailure' s = do
@@ -33,5 +33,13 @@ instance NameTest Result where
 instance (Arbitrary a,Show a,Testable b) => NameTest (a -> b) where
     nameTest name = nameTest name . property
 
+instance (Testable a) => NameTest (Gen a) where
+    nameTest name = nameTest name . property
+
 tgroup :: (Show a,NameTest t) => [a] -> (a -> t) -> [TestTree]
 tgroup aa f = fmap (\a -> nameTest (show a) $ f a) aa
+
+assertEqualQC :: (Show a,Eq a) => String -> a -> a -> Result
+assertEqualQC _name expected found | expected == found = succeeded
+assertEqualQC "" expected found = failed{reason="expected "++show expected++", found "++show found}
+assertEqualQC name expected found = failed{reason=name++": expected "++show expected++", found "++show found}