[commit: packages/time] master: more TestInstance clean-up (0417890)
git at git.haskell.org
git at git.haskell.org
Fri Jan 23 23:00:57 UTC 2015
Repository : ssh://git@git.haskell.org/time
On branch : master
Link : http://git.haskell.org/packages/time.git/commitdiff/041789051b0d6aa09d03560bf0b5b3c7fda9c645
>---------------------------------------------------------------
commit 041789051b0d6aa09d03560bf0b5b3c7fda9c645
Author: Ashley Yakeley <ashley at semantic.org>
Date: Sun Oct 28 22:28:49 2012 -0700
more TestInstance clean-up
Ignore-this: 2596abdead9de1796655be9e58f2ce95
darcs-hash:20121029052849-ac6dd-ebd63fbd2dd9044bcd2ec8f5c5073c5514eac0f5
>---------------------------------------------------------------
041789051b0d6aa09d03560bf0b5b3c7fda9c645
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 | 4 ++--
Test/TestMonthDay.hs | 2 +-
Test/TestParseDAT.hs | 2 +-
Test/TestTime.hs | 2 +-
Test/TestUtil.hs | 38 +++++++++++++++++---------------------
11 files changed, 28 insertions(+), 32 deletions(-)
diff --git a/Test/AddDays.hs b/Test/AddDays.hs
index a3754d9..0066673 100644
--- a/Test/AddDays.hs
+++ b/Test/AddDays.hs
@@ -43,5 +43,5 @@ resultDays = do
addDaysTest :: Test
addDaysTest
- = Test $ pure $ SimpleTest "addDays"
+ = Test $ pure "addDays"
$ diff addDaysRef $ unlines resultDays
diff --git a/Test/ClipDates.hs b/Test/ClipDates.hs
index 1b5d35f..761b9e9 100644
--- a/Test/ClipDates.hs
+++ b/Test/ClipDates.hs
@@ -35,7 +35,7 @@ tupleUp3 l1 l2 l3
clipDates :: Test
clipDates
- = Test $ pure $ SimpleTest "clipDates"
+ = Test $ pure "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 ce0238b..857e80f 100644
--- a/Test/ConvertBack.hs
+++ b/Test/ConvertBack.hs
@@ -42,5 +42,5 @@ days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++
convertBack :: Test
convertBack
- = Test $ pure $ SimpleTest "convertBack"
+ = Test $ pure "convertBack"
$ diff "" $ concatMap (\ch -> concatMap ch days) checkers
diff --git a/Test/LongWeekYears.hs b/Test/LongWeekYears.hs
index 7824425..220b3c7 100644
--- a/Test/LongWeekYears.hs
+++ b/Test/LongWeekYears.hs
@@ -22,5 +22,5 @@ showLongYear year
longWeekYears :: Test
longWeekYears
- = Test $ pure $ SimpleTest "longWeekYears"
+ = Test $ pure "longWeekYears"
$ diff longWeekYearsRef $ unlines $ map showLongYear [1901 .. 2050]
diff --git a/Test/TestCalendars.hs b/Test/TestCalendars.hs
index 324b792..5f1932c 100644
--- a/Test/TestCalendars.hs
+++ b/Test/TestCalendars.hs
@@ -29,7 +29,7 @@ days = [
testCalendars :: Test
testCalendars
- = Test $ pure $ SimpleTest "testCalendars"
+ = Test $ pure "testCalendars"
$ diff testCalendarsRef
$ unlines $ map (\d -> showShowers d) days
where
diff --git a/Test/TestEaster.hs b/Test/TestEaster.hs
index b6b9bd7..e97c84e 100644
--- a/Test/TestEaster.hs
+++ b/Test/TestEaster.hs
@@ -21,7 +21,7 @@ showWithWDay = formatTime defaultTimeLocale "%F %A"
testEaster :: Test
testEaster
- = Test $ pure $ SimpleTest "testEaster"
+ = Test $ pure "testEaster"
$ let ds = unlines $ map (\day ->
unwords [ showWithWDay day, "->"
, showWithWDay (sundayAfter day)]) days
diff --git a/Test/TestFormat.hs b/Test/TestFormat.hs
index eb8b2ee..001de68 100644
--- a/Test/TestFormat.hs
+++ b/Test/TestFormat.hs
@@ -75,7 +75,7 @@ times = [baseTime0] ++ (fmap getDay [0..23]) ++ (fmap getDay [0..100]) ++
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)) $
+ impure (testname ++ ": " ++ (show fmt) ++ " of " ++ (show ctime)) $
do
let haskellText = formatTime locale fmt ctime
unixText <- fmap modUnix (unixFormatTime fmt zone time)
@@ -124,7 +124,7 @@ safeString s = do
[] -> return ""
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
+compareExpected testname fmt str expected = impure (testname ++ ": " ++ (show fmt) ++ " on " ++ (show str)) $ do
let found = parseTime defaultTimeLocale fmt str
mex <- getBottom found
case mex of
diff --git a/Test/TestMonthDay.hs b/Test/TestMonthDay.hs
index 0d3a665..fa3bdcc 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
- = Test $ pure $ SimpleTest "testMonthDay"
+ = Test $ pure "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 187d062..313758d 100644
--- a/Test/TestParseDAT.hs
+++ b/Test/TestParseDAT.hs
@@ -43,7 +43,7 @@ times =
testParseDAT :: Test
testParseDAT
- = Test $ pure $ SimpleTest "testParseDAT"
+ = Test $ pure "testParseDAT"
$ diff testParseDAT_Ref parseDAT
where
parseDAT =
diff --git a/Test/TestTime.hs b/Test/TestTime.hs
index c47712e..cfa476b 100644
--- a/Test/TestTime.hs
+++ b/Test/TestTime.hs
@@ -108,5 +108,5 @@ testTimeOfDayToDayFraction
testTime :: Test
testTime
- = Test $ pure $ SimpleTest "testTime"
+ = Test $ pure "testTime"
$ diff testTimeRef $ unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction]
diff --git a/Test/TestUtil.hs b/Test/TestUtil.hs
index 776b859..88d95d2 100644
--- a/Test/TestUtil.hs
+++ b/Test/TestUtil.hs
@@ -6,19 +6,21 @@ module Test.TestUtil
import Distribution.TestSuite
-data SimpleTest = SimpleTest String Result
-
-pure :: SimpleTest -> TestInstance
-pure (SimpleTest name result) = TestInstance (return (Finished result)) name [] [] (\_ _ -> Left "")
-
-data IO_SimpleTest = IO_SimpleTest String (IO Result)
+impure :: String -> IO Result -> TestInstance
+impure name mresult = TestInstance {
+ run = fmap Finished mresult,
+ name = name,
+ tags = [],
+ options = [],
+ setOption = \_ _ -> Left "unsupported"
+}
-impure :: IO_SimpleTest -> TestInstance
-impure (IO_SimpleTest name mresult) = TestInstance (fmap Finished mresult) name [] [] (\_ _ -> Left "")
+pure :: String -> Result -> TestInstance
+pure name result = impure name (return result)
diff :: String -> String -> Result
-diff s t
- = if s == t then Pass else Fail ""
+diff s t | s == t = Pass
+diff _ _ = Fail ""
finish :: IO Progress -> IO Result
finish iop = do
@@ -27,24 +29,18 @@ finish iop = do
Finished result -> return result
Progress _ iop' -> finish iop'
-concatRun :: [IO Progress] -> IO Progress
-concatRun [] = return (Finished Pass)
+concatRun :: [IO Progress] -> IO Result
+concatRun [] = return Pass
concatRun (iop:iops) = do
result <- finish iop
case result of
Pass -> concatRun iops
- _ -> return (Finished result)
+ _ -> return result
concatTestInstance :: String -> [TestInstance] -> TestInstance
-concatTestInstance tname tis = TestInstance {
- run = concatRun (fmap run tis),
- name = tname,
- tags = [],
- options = [],
- setOption = \_ _ -> Left "unsupported"
-}
+concatTestInstance tname tis = impure tname (concatRun (fmap run tis))
fastTestInstanceGroup :: String -> [TestInstance] -> Test
---fastTestGroup tname tis = testGroup tname (fmap Test tis)
+fastTestInstanceGroup tname tis | False = testGroup tname (fmap Test tis)
fastTestInstanceGroup tname tis = Test (concatTestInstance tname tis)
More information about the ghc-commits
mailing list