diff --git a/test/unix/Test/Format/Format.hs b/test/unix/Test/Format/Format.hs
index 1512c7706ac8981c356a5a178db4310758406a44..77ae8e4a74b08ce17b7d04ab06b0e4a80988a948 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,27 +86,37 @@ chars :: [Char]
chars = "aAbBcCdDeFgGhHIjklmMnprRStTuUVwWxXyYzZ%"
-- as found in "man strftime" on a glibc system. '#' is different, though
-modifiers :: [Char]
-modifiers = "_-0^"
+modifiers :: [String]
+modifiers = ["","_","-","0","^"]
widths :: [String]
widths = ["","1","2","9","12"]
formats :: [String]
-formats = ["%G-W%V-%u","%U-%w","%W-%u"] ++ (fmap (\char -> '%':[char]) chars)
- ++ (concat $ fmap (\char -> concat $ fmap (\width -> fmap (\modifier -> "%" ++ [modifier] ++ width ++ [char]) modifiers) widths) chars)
+formats = ["%G-W%V-%u","%U-%w","%W-%u"]
+ ++ (do
+ char <- chars
+ width <- widths
+ modifier <- modifiers
+ return $ "%" ++ modifier ++ width ++ [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 c306893ed018a41b761ff2fa393c0e7c071c5c55..4a3b42d67b8452f934463b672e3a4b38cbe68b3b 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}