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