From 54a7b3baccde8bcafd9238f587f728e9beb73b7f Mon Sep 17 00:00:00 2001 From: Ashley Yakeley <ashley@semantic.org> Date: Sun, 28 Oct 2012 17:05:35 -0700 Subject: [PATCH] clean up tests Ignore-this: daf151d23ca95cf9938f58b2378b68df darcs-hash:20121029000535-ac6dd-aa7918f6f704d0591e929c58c506b69250593844 --- Test/AddDays.hs | 2 +- Test/ClipDates.hs | 2 +- Test/ConvertBack.hs | 2 +- Test/LongWeekYears.hs | 2 +- Test/TestCalendars.hs | 2 +- Test/TestEaster.hs | 2 +- Test/TestFormat.hs | 103 +++++++++++++++++------------------------- Test/TestMonthDay.hs | 2 +- Test/TestParseDAT.hs | 2 +- Test/TestTime.hs | 2 +- Test/TestUtil.hs | 37 +++++++++++++-- 11 files changed, 83 insertions(+), 75 deletions(-) diff --git a/Test/AddDays.hs b/Test/AddDays.hs index 3e65cc8..a3754d9 100644 --- a/Test/AddDays.hs +++ b/Test/AddDays.hs @@ -43,5 +43,5 @@ resultDays = do addDaysTest :: Test addDaysTest - = pure $ SimpleTest "addDays" + = Test $ pure $ SimpleTest "addDays" $ diff addDaysRef $ unlines resultDays diff --git a/Test/ClipDates.hs b/Test/ClipDates.hs index 4cdf19c..1b5d35f 100644 --- a/Test/ClipDates.hs +++ b/Test/ClipDates.hs @@ -35,7 +35,7 @@ tupleUp3 l1 l2 l3 clipDates :: Test clipDates - = pure $ SimpleTest "clipDates" + = Test $ pure $ SimpleTest "clipDates" $ let yad = unlines $ map yearAndDay $ tupleUp2 [1968,1969,1971] [-4,0,1,200,364,365,366,367,700] diff --git a/Test/ConvertBack.hs b/Test/ConvertBack.hs index b7910aa..ce0238b 100644 --- a/Test/ConvertBack.hs +++ b/Test/ConvertBack.hs @@ -42,5 +42,5 @@ days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++ convertBack :: Test convertBack - = pure $ SimpleTest "convertBack" + = Test $ pure $ SimpleTest "convertBack" $ diff "" $ concatMap (\ch -> concatMap ch days) checkers diff --git a/Test/LongWeekYears.hs b/Test/LongWeekYears.hs index 51e550a..7824425 100644 --- a/Test/LongWeekYears.hs +++ b/Test/LongWeekYears.hs @@ -22,5 +22,5 @@ showLongYear year longWeekYears :: Test longWeekYears - = pure $ SimpleTest "longWeekYears" + = Test $ pure $ SimpleTest "longWeekYears" $ diff longWeekYearsRef $ unlines $ map showLongYear [1901 .. 2050] diff --git a/Test/TestCalendars.hs b/Test/TestCalendars.hs index 629d20e..324b792 100644 --- a/Test/TestCalendars.hs +++ b/Test/TestCalendars.hs @@ -29,7 +29,7 @@ days = [ testCalendars :: Test testCalendars - = pure $ SimpleTest "testCalendars" + = Test $ pure $ SimpleTest "testCalendars" $ diff testCalendarsRef $ unlines $ map (\d -> showShowers d) days where diff --git a/Test/TestEaster.hs b/Test/TestEaster.hs index de8b45f..b6b9bd7 100644 --- a/Test/TestEaster.hs +++ b/Test/TestEaster.hs @@ -21,7 +21,7 @@ showWithWDay = formatTime defaultTimeLocale "%F %A" testEaster :: Test testEaster - = pure $ SimpleTest "testEaster" + = Test $ pure $ SimpleTest "testEaster" $ let ds = unlines $ map (\day -> unwords [ showWithWDay day, "->" , showWithWDay (sundayAfter day)]) days diff --git a/Test/TestFormat.hs b/Test/TestFormat.hs index 0f1aa4d..eb8b2ee 100644 --- a/Test/TestFormat.hs +++ b/Test/TestFormat.hs @@ -6,7 +6,6 @@ import Data.Time import Data.Time.Clock.POSIX import Data.Char -import Data.Functor import System.Locale import Foreign @@ -73,17 +72,17 @@ times :: [UTCTime] times = [baseTime0] ++ (fmap getDay [0..23]) ++ (fmap getDay [0..100]) ++ (fmap getYearP1 [1980..2000]) ++ (fmap getYearP2 [1980..2000]) ++ (fmap getYearP3 [1980..2000]) ++ (fmap getYearP4 [1980..2000]) -compareFormat :: (String -> String) -> String -> TimeZone -> UTCTime -> IO Bool -compareFormat modUnix fmt zone time - = do let ctime = utcToZonedTime zone time - haskellText = formatTime locale fmt ctime - unixText <- fmap modUnix (unixFormatTime fmt zone time) - if haskellText == unixText - then return True -- "" - else return False - {- unwords - [ "Mismatch with", fmt, "for" - , show ctime ++ ": UNIX=\"" ++ unixText ++ "\", TimeLib=\"" ++ haskellText ++ "\"."] -} +compareFormat :: String -> (String -> String) -> String -> TimeZone -> UTCTime -> TestInstance +compareFormat testname modUnix fmt zone time = + let ctime = utcToZonedTime zone time in + impure $ IO_SimpleTest (testname ++ ": " ++ (show fmt) ++ " of " ++ (show ctime)) $ + do + let haskellText = formatTime locale fmt ctime + unixText <- fmap modUnix (unixFormatTime fmt zone time) + if haskellText == unixText + then return Pass + else return $ Fail $ unwords + [ "Mismatch for", show ctime ++ ": UNIX=\"" ++ unixText ++ "\", TimeLib=\"" ++ haskellText ++ "\"."] -- as found in http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html -- plus FgGklz @@ -124,28 +123,18 @@ safeString s = do return (c:ss) [] -> return "" -compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> IO Bool -compareExpected _ fmt str expected - = do let found = parseTime defaultTimeLocale fmt str - mex <- getBottom found - case mex of - Just _ -> return False - {- return $ unwords - [ "Exception with", fmt - , "for", ts - , show str ++ ": expected" - , show expected ++ ", caught", show ex] -} - - Nothing -> +compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> TestInstance +compareExpected testname fmt str expected = impure $ IO_SimpleTest (testname ++ ": " ++ (show fmt) ++ " on " ++ (show str)) $ do + let found = parseTime defaultTimeLocale fmt str + mex <- getBottom found + case mex of + Just ex -> return $ Fail $ unwords [ "Exception: expected" , show expected ++ ", caught", show ex] + Nothing -> if found == expected - then return True -- return "" - else return False - {- do sf <- safeString (show found) - return $ unwords - [ "Mismatch with", fmt - , "for", ts - , show str ++ ": expected" - , show expected ++ ", found", sf] -} + then return Pass + else do + sf <- safeString (show found) + return $ Fail $ unwords [ "Mismatch: expected", show expected ++ ", found", sf] class (ParseTime t) => TestParse t where expectedParse :: String -> String -> Maybe t @@ -162,39 +151,29 @@ instance TestParse TimeZone instance TestParse ZonedTime instance TestParse UTCTime -checkParse :: String -> String -> IO [Bool] +checkParse :: String -> String -> [TestInstance] checkParse fmt str - = sequence [ compareExpected "Day" fmt str (expectedParse fmt str :: Maybe Day) + = [ 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) ] +testCheckParse :: [TestInstance] +testCheckParse = concatMap (\fmt -> concatMap (\str -> checkParse fmt str) somestrings) formats + +testCompareFormat :: [TestInstance] +testCompareFormat = concatMap (\fmt -> concatMap (\time -> fmap (\zone -> compareFormat "compare format" id fmt zone time) zones) times) formats + +testCompareHashFormat :: [TestInstance] +testCompareHashFormat = concatMap (\fmt -> concatMap (\time -> fmap (\zone -> compareFormat "compare hashformat" (fmap toLower) fmt zone time) zones) times) hashformats + +testFormats :: [Test] +testFormats = [ + fastTestInstanceGroup "checkParse" testCheckParse, + fastTestInstanceGroup "compare format" testCompareFormat, + fastTestInstanceGroup "compare hashformat" testCompareHashFormat + ] + testFormat :: Test -testFormat - = impure $ IO_SimpleTest "testFormat" - $ do a <- concat <$> mapM (\fmt -> concat <$> mapM (checkParse fmt) somestrings) formats - let a' = if all (== True) a - then Pass - else Fail $ "testFormat: checkParse failed" - - b <- mapM (\fmt -> mapM (\time -> mapM (\zone -> compareFormat id fmt zone time) zones) times) formats - let b' = if all (== True) $ concat $ concat b - then Pass - else Fail $ "testFormat: compareFormat failed on variable formats" - - c <- mapM (\fmt -> mapM (\time -> mapM (\zone -> compareFormat (fmap toLower) fmt zone time) zones) times) hashformats - let c' = if all (== True) $ concat $ concat c - then Pass - else Fail $ "testFormat: compareFormat failed on variable hashFormats" - - let fs = concatFailures [a', b', c'] - return $ if null fs then Pass else Fail $ fs - -concatFailures :: [Result] -> String -concatFailures - = foldr (\e s -> - case e - of Fail f -> f ++ "\n" ++ s - _ -> s) - "" +testFormat = testGroup "testFormat" testFormats diff --git a/Test/TestMonthDay.hs b/Test/TestMonthDay.hs index 6bea84b..0d3a665 100644 --- a/Test/TestMonthDay.hs +++ b/Test/TestMonthDay.hs @@ -15,7 +15,7 @@ showCompare a1 b a2 = "DIFF: " ++ (show a1) ++ " -> " ++ b ++ " -> " ++ (show a2 testMonthDay :: Test testMonthDay - = pure $ SimpleTest "testMonthDay" + = Test $ pure $ SimpleTest "testMonthDay" $ diff testMonthDayRef $ concat $ map (\isL -> unlines (leap isL : yearDays isL)) [False,True] where diff --git a/Test/TestParseDAT.hs b/Test/TestParseDAT.hs index 2ae53df..187d062 100644 --- a/Test/TestParseDAT.hs +++ b/Test/TestParseDAT.hs @@ -43,7 +43,7 @@ times = testParseDAT :: Test testParseDAT - = pure $ SimpleTest "testParseDAT" + = Test $ pure $ SimpleTest "testParseDAT" $ diff testParseDAT_Ref parseDAT where parseDAT = diff --git a/Test/TestTime.hs b/Test/TestTime.hs index 30473b2..c47712e 100644 --- a/Test/TestTime.hs +++ b/Test/TestTime.hs @@ -108,5 +108,5 @@ testTimeOfDayToDayFraction testTime :: Test testTime - = pure $ SimpleTest "testTime" + = Test $ pure $ SimpleTest "testTime" $ diff testTimeRef $ unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction] diff --git a/Test/TestUtil.hs b/Test/TestUtil.hs index 2c0be91..776b859 100644 --- a/Test/TestUtil.hs +++ b/Test/TestUtil.hs @@ -8,14 +8,43 @@ import Distribution.TestSuite data SimpleTest = SimpleTest String Result -pure :: SimpleTest -> Test -pure (SimpleTest name result) = Test (TestInstance (return (Finished result)) name [] [] (\_ _ -> Left "")) +pure :: SimpleTest -> TestInstance +pure (SimpleTest name result) = TestInstance (return (Finished result)) name [] [] (\_ _ -> Left "") data IO_SimpleTest = IO_SimpleTest String (IO Result) -impure :: IO_SimpleTest -> Test -impure (IO_SimpleTest name mresult) = Test (TestInstance (fmap Finished mresult) name [] [] (\_ _ -> Left "")) +impure :: IO_SimpleTest -> TestInstance +impure (IO_SimpleTest name mresult) = TestInstance (fmap Finished mresult) name [] [] (\_ _ -> Left "") diff :: String -> String -> Result diff s t = if s == t then Pass else Fail "" + +finish :: IO Progress -> IO Result +finish iop = do + progress <- iop + case progress of + Finished result -> return result + Progress _ iop' -> finish iop' + +concatRun :: [IO Progress] -> IO Progress +concatRun [] = return (Finished Pass) +concatRun (iop:iops) = do + result <- finish iop + case result of + Pass -> concatRun iops + _ -> return (Finished result) + +concatTestInstance :: String -> [TestInstance] -> TestInstance +concatTestInstance tname tis = TestInstance { + run = concatRun (fmap run tis), + name = tname, + tags = [], + options = [], + setOption = \_ _ -> Left "unsupported" +} + +fastTestInstanceGroup :: String -> [TestInstance] -> Test +--fastTestGroup tname tis = testGroup tname (fmap Test tis) +fastTestInstanceGroup tname tis = Test (concatTestInstance tname tis) + -- GitLab