From 500ca2046c1f85279a4b2b95b71dadc5f4c22986 Mon Sep 17 00:00:00 2001
From: Ashley Yakeley <ashley@semantic.org>
Date: Wed, 14 Nov 2012 20:17:38 -0800
Subject: [PATCH] fix up test infrastructure
Ignore-this: 884e829c58ee215ab63a75114c0627ec
darcs-hash:20121115041738-ac6dd-c747d085442d3b43b6c8f66bf7b78431ad2efd4b
---
Makefile | 2 +-
Test/AddDays.hs | 10 +--
Test/ClipDates.hs | 30 +++------
Test/ConvertBack.hs | 10 +--
Test/LongWeekYears.hs | 10 +--
Test/TestCalendars.hs | 17 ++---
Test/TestEaster.hs | 12 ++--
Test/TestFormat.hs | 49 ++++++---------
Test/TestMonthDay.hs | 29 ++++-----
Test/TestParseDAT.hs | 35 +++++------
Test/TestParseTime.hs | 127 ++++++++++++++++++++------------------
Test/TestTime.hs | 10 +--
Test/TestUtil.hs | 85 +++++++++++++------------
Test/Tests.hs | 8 ++-
time.cabal | 140 +++++++++++++++++++++++++-----------------
15 files changed, 267 insertions(+), 307 deletions(-)
diff --git a/Makefile b/Makefile
index 37a78fc..4fe6afb 100644
--- a/Makefile
+++ b/Makefile
@@ -12,7 +12,7 @@ build: configure
cabal build --ghc-options=-Werror
test: build
- cabal test
+ cabal test --test-option=--hide-successes --test-option=--color
haddock: configure
cabal haddock
diff --git a/Test/AddDays.hs b/Test/AddDays.hs
index 0066673..8543c15 100644
--- a/Test/AddDays.hs
+++ b/Test/AddDays.hs
@@ -1,14 +1,9 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.AddDays where
import Data.Time.Calendar
-
import Test.TestUtil
import Test.AddDaysRef
---
-
days ::[Day]
days =
[
@@ -42,6 +37,5 @@ resultDays = do
return ((showGregorian day) ++ " + " ++ (show increment) ++ " * " ++ aname ++ " = " ++ showGregorian (adder increment day))
addDaysTest :: Test
-addDaysTest
- = Test $ pure "addDays"
- $ diff addDaysRef $ unlines resultDays
+addDaysTest = pureTest "addDays" $
+ diff addDaysRef $ unlines resultDays
diff --git a/Test/ClipDates.hs b/Test/ClipDates.hs
index 761b9e9..54667a6 100644
--- a/Test/ClipDates.hs
+++ b/Test/ClipDates.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS -Wall -Werror #-}
{-# Language TupleSections #-}
module Test.ClipDates where
@@ -6,12 +5,9 @@ module Test.ClipDates where
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar
-
import Test.TestUtil
import Test.ClipDatesRef
---
-
yearAndDay :: (Integer,Int) -> String
yearAndDay (y,d) = (show y) ++ "-" ++ (show d) ++ " = " ++ (showOrdinalDate (fromOrdinalDate y d))
@@ -34,23 +30,17 @@ tupleUp3 l1 l2 l3
--
clipDates :: Test
-clipDates
- = Test $ pure "clipDates"
- $ let yad = unlines $ map yearAndDay
- $ tupleUp2 [1968,1969,1971] [-4,0,1,200,364,365,366,367,700]
+clipDates = pureTest "clipDates" $
+ let
+ yad = unlines $ map yearAndDay $
+ tupleUp2 [1968,1969,1971] [-4,0,1,200,364,365,366,367,700]
- greg = unlines $ map gregorian
- $ tupleUp3 [1968,1969,1971]
- [-20,-1,0,1,2,12,13,17]
- [-7,-1,0,1,2,27,28,29,30,31,32,40]
+ greg = unlines $ map gregorian $
+ tupleUp3 [1968,1969,1971] [-20,-1,0,1,2,12,13,17] [-7,-1,0,1,2,27,28,29,30,31,32,40]
- iso = unlines $ map iSOWeekDay
- $ tupleUp3 [1968,1969,2004]
- [-20,-1,0,1,20,51,52,53,54]
- [-2,-1,0,1,4,6,7,8,9]
+ iso = unlines $ map iSOWeekDay $
+ tupleUp3 [1968,1969,2004] [-20,-1,0,1,20,51,52,53,54] [-2,-1,0,1,4,6,7,8,9]
- in diff clipDatesRef
- $ concat [ "YearAndDay\n", yad
- , "Gregorian\n", greg
- , "ISOWeekDay\n", iso ]
+ in diff clipDatesRef $
+ concat [ "YearAndDay\n", yad, "Gregorian\n", greg, "ISOWeekDay\n", iso ]
diff --git a/Test/ConvertBack.hs b/Test/ConvertBack.hs
index 857e80f..a0c43a4 100644
--- a/Test/ConvertBack.hs
+++ b/Test/ConvertBack.hs
@@ -1,16 +1,11 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.ConvertBack where
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Julian
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar
-
import Test.TestUtil
---
-
checkDay :: (Show t) => (Day -> t) -> (t -> Day) -> (t -> Maybe Day) -> Day -> String
checkDay encodeDay decodeDay decodeDayValid day
= let st = encodeDay day
@@ -41,6 +36,5 @@ days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++
(fmap (\year -> (fromGregorian year 1 4)) [1980..2000])
convertBack :: Test
-convertBack
- = Test $ pure "convertBack"
- $ diff "" $ concatMap (\ch -> concatMap ch days) checkers
+convertBack = pureTest "convertBack" $
+ diff "" $ concatMap (\ch -> concatMap ch days) checkers
diff --git a/Test/LongWeekYears.hs b/Test/LongWeekYears.hs
index 220b3c7..31c551f 100644
--- a/Test/LongWeekYears.hs
+++ b/Test/LongWeekYears.hs
@@ -1,15 +1,10 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.LongWeekYears where
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar
-
import Test.TestUtil
import Test.LongWeekYearsRef
---
-
longYear :: Integer -> Bool
longYear year = case toWeekDate (fromGregorian year 12 31) of
(_,53,_) -> True
@@ -21,6 +16,5 @@ showLongYear year
, (if isLeapYear year then "L" else " ") ++ (if longYear year then "*" else " ") ]
longWeekYears :: Test
-longWeekYears
- = Test $ pure "longWeekYears"
- $ diff longWeekYearsRef $ unlines $ map showLongYear [1901 .. 2050]
+longWeekYears = pureTest "longWeekYears" $
+ diff longWeekYearsRef $ unlines $ map showLongYear [1901 .. 2050]
diff --git a/Test/TestCalendars.hs b/Test/TestCalendars.hs
index 5f1932c..8be376c 100644
--- a/Test/TestCalendars.hs
+++ b/Test/TestCalendars.hs
@@ -1,16 +1,11 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.TestCalendars where
import Data.Time.Calendar.Julian
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar
-
import Test.TestUtil
import Test.TestCalendarsRef
---
-
showers :: [(String,Day -> String)]
showers = [
("MJD",show . toModifiedJulianDay),
@@ -28,10 +23,8 @@ days = [
]
testCalendars :: Test
-testCalendars
- = Test $ pure "testCalendars"
- $ diff testCalendarsRef
- $ unlines $ map (\d -> showShowers d) days
- where
- showShowers day
- = concatMap (\(nm,shower) -> unwords [" ==", nm, shower day]) showers
+testCalendars = pureTest "testCalendars" $
+ diff testCalendarsRef $ unlines $ map (\d -> showShowers d) days
+ where
+ showShowers day =
+ concatMap (\(nm,shower) -> unwords [" ==", nm, shower day]) showers
diff --git a/Test/TestEaster.hs b/Test/TestEaster.hs
index e97c84e..20c8889 100644
--- a/Test/TestEaster.hs
+++ b/Test/TestEaster.hs
@@ -20,21 +20,19 @@ showWithWDay :: Day -> String
showWithWDay = formatTime defaultTimeLocale "%F %A"
testEaster :: Test
-testEaster
- = Test $ pure "testEaster"
- $ let ds = unlines $ map (\day ->
+testEaster = pureTest "testEaster" $ let
+ ds = unlines $ map (\day ->
unwords [ showWithWDay day, "->"
, showWithWDay (sundayAfter day)]) days
- f y = unwords [ show y ++ ", Gregorian: moon,"
+ f y = unwords [ show y ++ ", Gregorian: moon,"
, show (gregorianPaschalMoon y) ++ ": Easter,"
, showWithWDay (gregorianEaster y)]
++ "\n"
- g y = unwords [ show y ++ ", Orthodox : moon,"
+ g y = unwords [ show y ++ ", Orthodox : moon,"
, show (orthodoxPaschalMoon y) ++ ": Easter,"
, showWithWDay (orthodoxEaster y)]
++ "\n"
- in diff testEasterRef
- $ ds ++ concatMap (\y -> f y ++ g y) [2000..2020]
+ in diff testEasterRef $ ds ++ concatMap (\y -> f y ++ g y) [2000..2020]
diff --git a/Test/TestFormat.hs b/Test/TestFormat.hs
index 3aae5e5..c063847 100644
--- a/Test/TestFormat.hs
+++ b/Test/TestFormat.hs
@@ -1,21 +1,16 @@
-{-# OPTIONS -XForeignFunctionInterface -Wall -Werror #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
module Test.TestFormat where
import Data.Time
import Data.Time.Clock.POSIX
-
import Data.Char
-
import System.Locale
import Foreign
import Foreign.C
import Control.Exception;
-
import Test.TestUtil
---
-
{-
size_t format_time (
char *s, size_t maxsize,
@@ -75,17 +70,14 @@ times :: [UTCTime]
times = [baseTime0] ++ (fmap getDay [0..23]) ++ (fmap getDay [0..100]) ++
(fmap getYearP1 years) ++ (fmap getYearP2 years) ++ (fmap getYearP3 years) ++ (fmap getYearP4 years)
-compareFormat :: String -> (String -> String) -> String -> TimeZone -> UTCTime -> TestInstance
-compareFormat testname modUnix fmt zone time =
- let ctime = utcToZonedTime zone time in
- impure (testname ++ ": " ++ (show fmt) ++ " of " ++ (show ctime)) $
+compareFormat :: String -> (String -> String) -> String -> TimeZone -> UTCTime -> Test
+compareFormat testname modUnix fmt zone time = let
+ ctime = utcToZonedTime zone time
+ haskellText = formatTime locale fmt ctime
+ in ioTest (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 ++ "\"."]
+ unixText <- fmap modUnix (unixFormatTime fmt zone time)
+ return $ diff unixText haskellText
-- as found in http://www.opengroup.org/onlinepubs/007908799/xsh/strftime.html
-- plus FgGklz
@@ -126,18 +118,13 @@ safeString s = do
return (c:ss)
[] -> return ""
-compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> TestInstance
-compareExpected testname fmt str expected = impure (testname ++ ": " ++ (show fmt) ++ " on " ++ (show str)) $ do
+compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> Test
+compareExpected testname fmt str expected = ioTest (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 Pass
- else do
- sf <- safeString (show found)
- return $ Fail $ unwords [ "Mismatch: expected", show expected ++ ", found", sf]
+ Nothing -> return $ diff expected found
class (ParseTime t) => TestParse t where
expectedParse :: String -> String -> Maybe t
@@ -154,7 +141,7 @@ instance TestParse TimeZone
instance TestParse ZonedTime
instance TestParse UTCTime
-checkParse :: String -> String -> [TestInstance]
+checkParse :: String -> String -> [Test]
checkParse fmt str
= [ compareExpected "Day" fmt str (expectedParse fmt str :: Maybe Day)
, compareExpected "TimeOfDay" fmt str (expectedParse fmt str :: Maybe TimeOfDay)
@@ -162,20 +149,20 @@ checkParse fmt str
, compareExpected "TimeZone" fmt str (expectedParse fmt str :: Maybe TimeZone)
, compareExpected "UTCTime" fmt str (expectedParse fmt str :: Maybe UTCTime) ]
-testCheckParse :: [TestInstance]
+testCheckParse :: [Test]
testCheckParse = concatMap (\fmt -> concatMap (\str -> checkParse fmt str) somestrings) formats
-testCompareFormat :: [TestInstance]
+testCompareFormat :: [Test]
testCompareFormat = concatMap (\fmt -> concatMap (\time -> fmap (\zone -> compareFormat "compare format" id fmt zone time) zones) times) formats
-testCompareHashFormat :: [TestInstance]
+testCompareHashFormat :: [Test]
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
+ testGroup "checkParse" testCheckParse,
+ testGroup "compare format" testCompareFormat,
+ testGroup "compare hashformat" testCompareHashFormat
]
testFormat :: Test
diff --git a/Test/TestMonthDay.hs b/Test/TestMonthDay.hs
index fa3bdcc..f97f3f5 100644
--- a/Test/TestMonthDay.hs
+++ b/Test/TestMonthDay.hs
@@ -1,29 +1,22 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.TestMonthDay where
import Data.Time.Calendar.MonthDay
-
import Test.TestUtil
import Test.TestMonthDayRef
---
-
showCompare :: (Eq a,Show a) => a -> String -> a -> String
showCompare a1 b a2 | a1 == a2 = (show a1) ++ " == " ++ b
showCompare a1 b a2 = "DIFF: " ++ (show a1) ++ " -> " ++ b ++ " -> " ++ (show a2)
testMonthDay :: Test
-testMonthDay
- = Test $ pure "testMonthDay"
- $ diff testMonthDayRef
- $ concat $ map (\isL -> unlines (leap isL : yearDays isL)) [False,True]
- where
- leap isLeap = if isLeap then "Leap:" else "Regular:"
-
- yearDays isLeap
- = map (\yd -> let (m,d) = dayOfYearToMonthAndDay isLeap yd
- yd' = monthAndDayToDayOfYear isLeap m d
- mdtext = show m ++ "-" ++ show d
- in showCompare yd mdtext yd')
- [-2..369]
+testMonthDay = pureTest "testMonthDay" $
+ diff testMonthDayRef $ concat $ map (\isL -> unlines (leap isL : yearDays isL)) [False,True]
+ where
+ leap isLeap = if isLeap then "Leap:" else "Regular:"
+ yearDays isLeap =
+ map (\yd -> let
+ (m,d) = dayOfYearToMonthAndDay isLeap yd
+ yd' = monthAndDayToDayOfYear isLeap m d
+ mdtext = show m ++ "-" ++ show d
+ in showCompare yd mdtext yd')
+ [-2..369]
diff --git a/Test/TestParseDAT.hs b/Test/TestParseDAT.hs
index 313758d..31b6ea5 100644
--- a/Test/TestParseDAT.hs
+++ b/Test/TestParseDAT.hs
@@ -1,16 +1,11 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.TestParseDAT where
import Data.Time
import Data.Time.Clock.TAI
-
import Test.TestUtil
import Test.TestParseDAT_Ref
import Test.TAI_UTC_DAT
---
-
tods :: [TimeOfDay]
tods = [
TimeOfDay 0 0 0,
@@ -42,19 +37,17 @@ times =
fmap (LocalTime (fromGregorian 1999 01 02)) tods
testParseDAT :: Test
-testParseDAT
- = Test $ pure "testParseDAT"
- $ diff testParseDAT_Ref parseDAT
- where
- parseDAT =
- let lst = parseTAIUTCDATFile taiUTC_DAT
- in unlines $
- map (\lt ->
- let utcTime = localTimeToUTC utc lt
- taiTime = utcToTAITime lst utcTime
- utcTime' = taiToUTCTime lst taiTime
- in if utcTime == utcTime'
- then unwords [show utcTime, "==", show taiTime]
- else unwords [ "correction:", show utcTime
- , "->", show taiTime, "->", show utcTime'])
- times
+testParseDAT = pureTest "testParseDAT" $ diff testParseDAT_Ref parseDAT where
+ parseDAT =
+ let lst = parseTAIUTCDATFile taiUTC_DAT in
+ unlines $ map
+ (\lt ->
+ let
+ utcTime = localTimeToUTC utc lt
+ taiTime = utcToTAITime lst utcTime
+ utcTime' = taiToUTCTime lst taiTime
+ in if utcTime == utcTime'
+ then unwords [show utcTime, "==", show taiTime]
+ else unwords [ "correction:", show utcTime, "->", show taiTime, "->", show utcTime']
+ )
+ times
diff --git a/Test/TestParseTime.hs b/Test/TestParseTime.hs
index b3d1b2f..823a3c1 100644
--- a/Test/TestParseTime.hs
+++ b/Test/TestParseTime.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -Wall -Werror -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-orphans #-}
+{-# OPTIONS -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances, ExistentialQuantification #-}
module Test.TestParseTime where
@@ -6,90 +6,84 @@ module Test.TestParseTime where
import Control.Monad
import Data.Char
import Data.Ratio
-import Data.Maybe
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Clock.POSIX
import System.Locale
-import System.Exit
-import Test.QuickCheck
-import Test.QuickCheck.Batch
+import Test.QuickCheck hiding (Result)
+--import qualified Test.QuickCheck
+import Test.TestUtil
+--import qualified Test.TestUtil
-class RunTest p where
- runTest :: p -> IO TestResult
-
-instance RunTest (IO TestResult) where
- runTest iob = iob
-
-instance RunTest Property where
- runTest p = run p (TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False})
-
-data ExhaustiveTest = forall t. (Show t) => MkExhaustiveTest [t] (t -> IO Bool)
-
-instance RunTest ExhaustiveTest where
- runTest (MkExhaustiveTest cases f) = do
- results <- mapM (\t -> do {b <- f t;return (b,show t)}) cases
- let failures = mapMaybe (\(b,n) -> if b then Nothing else Just n) results
- let fcount = length failures
- return (if fcount == 0 then TestOk "OK" 0 [] else TestFailed failures fcount)
+--instance RunTest Property where
+-- runTest p = run p (TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False})
ntest :: Int
ntest = 1000
+type NamedProperty = (String, Property)
+
testParseTime :: Test
-testParseTime
- = impureTest $ Test "testParseTime"
- $ good1 <- checkAll extests
- good2 <- checkAll properties
- putStrLn "Known failures:"
- _ <- checkAll knownFailures
- return $ if good1 && good2
- then Pass
- else Fail "testParseTime failed and gave a redundant error message"
-
-days2011 :: [Day]
-days2011 = [(fromGregorian 2011 1 1) .. (fromGregorian 2011 12 31)]
-
-extests :: [(String,ExhaustiveTest)]
-extests = [
- ("parse %y",MkExhaustiveTest [0..99] parseYY),
- ("parse %C %y 1900s",MkExhaustiveTest [0..99] (parseCYY 19)),
- ("parse %C %y 2000s",MkExhaustiveTest [0..99] (parseCYY 20)),
- ("parse %C %y 1400s",MkExhaustiveTest [0..99] (parseCYY 14)),
- ("parse %C %y 700s",MkExhaustiveTest [0..99] (parseCYY 7)),
- ("parse %Y%m%d",MkExhaustiveTest days2011 parseYMD),
- ("parse %Y %m %d",MkExhaustiveTest days2011 parseYearDayD),
- ("parse %Y %-m %e",MkExhaustiveTest days2011 parseYearDayE)
+testParseTime = testGroup "testParseTime"
+ [
+ testGroup "extests" (fmap exhaustiveTestInstances extests),
+ testGroup "properties" (fmap (\(n,prop) -> testProperty n prop) properties)
]
-parseYMD :: Day -> IO Bool
+{-
+knownFailures
+-}
+yearDays :: Integer -> [Day]
+yearDays y = [(fromGregorian y 1 1) .. (fromGregorian y 12 31)]
+
+extests :: [ExhaustiveTest]
+extests = [
+ MkExhaustiveTest "parse %y" [0..99] parseYY,
+ MkExhaustiveTest "parse %C %y 1900s" [0..99] (parseCYY 19),
+ MkExhaustiveTest "parse %C %y 2000s" [0..99] (parseCYY 20),
+ MkExhaustiveTest "parse %C %y 1400s" [0..99] (parseCYY 14),
+ MkExhaustiveTest "parse %C %y 700s" [0..99] (parseCYY2 7),
+ MkExhaustiveTest "parse %C %y 700s" [0..99] (parseCYY 7)
+ ] ++
+ (concat $ fmap
+ (\y -> [
+ (MkExhaustiveTest "parse %Y%m%d" (yearDays y) parseYMD),
+ (MkExhaustiveTest "parse %Y %m %d" (yearDays y) parseYearDayD),
+ (MkExhaustiveTest "parse %Y %-m %e" (yearDays y) parseYearDayE)
+ ]) [1,20,753,2000,2011,10001])
+
+parseYMD :: Day -> IO Result
parseYMD day = case toGregorian day of
- (y,m,d) -> return $ (parse "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d))) == Just day
+ (y,m,d) -> return $ diff (Just day) (parse "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d)))
-parseYearDayD :: Day -> IO Bool
+parseYearDayD :: Day -> IO Result
parseYearDayD day = case toGregorian day of
- (y,m,d) -> return $ (parse "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d))) == Just day
+ (y,m,d) -> return $ diff (Just day) (parse "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d)))
-parseYearDayE :: Day -> IO Bool
+parseYearDayE :: Day -> IO Result
parseYearDayE day = case toGregorian day of
- (y,m,d) -> return $ (parse "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d))) == Just day
+ (y,m,d) -> return $ diff (Just day) (parse "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d)))
-- | 1969 - 2068
expectedYear :: Integer -> Integer
expectedYear i | i >= 69 = 1900 + i
expectedYear i = 2000 + i
-show2 :: (Integral n) => n -> String
+show2 :: (Show n,Integral n) => n -> String
show2 i = (show (div i 10)) ++ (show (mod i 10))
-parseYY :: Integer -> IO Bool
-parseYY i = return (parse "%y" (show2 i) == Just (fromGregorian (expectedYear i) 1 1))
+parseYY :: Integer -> IO Result
+parseYY i = return $ diff (Just (fromGregorian (expectedYear i) 1 1)) (parse "%y" (show2 i))
+
+parseCYY :: Integer -> Integer -> IO Result
+parseCYY c i = return $ diff (Just (fromGregorian ((c * 100) + i) 1 1)) (parse "%C %y" ((show c) ++ " " ++ (show2 i)))
-parseCYY :: Integer -> Integer -> IO Bool
-parseCYY c i = return (parse "%C %y" ((show2 c) ++ " " ++ (show2 i)) == Just (fromGregorian ((c * 100) + i) 1 1))
+parseCYY2 :: Integer -> Integer -> IO Result
+parseCYY2 c i = return $ diff (Just (fromGregorian ((c * 100) + i) 1 1)) (parse "%C %y" ((show2 c) ++ " " ++ (show2 i)))
+{-
checkAll :: RunTest p => [(String,p)] -> IO Bool
checkAll ps = fmap and (mapM checkOne ps)
@@ -112,7 +106,7 @@ checkOne (n,p) =
return (trGood tr)
where
rpad n' c xs = xs ++ replicate (n' - length xs) c
-
+-}
parse :: ParseTime t => String -> String -> Maybe t
parse f t = parseTime defaultTimeLocale f t
@@ -123,6 +117,8 @@ format f t = formatTime defaultTimeLocale f t
instance Arbitrary Day where
arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
+
+instance CoArbitrary Day where
coarbitrary (ModifiedJulianDay d) = coarbitrary d
instance Arbitrary DiffTime where
@@ -133,26 +129,38 @@ instance Arbitrary DiffTime where
secondsToDiffTime' = fromInteger
picosecondsToDiffTime' :: Integer -> DiffTime
picosecondsToDiffTime' x = fromRational (x % 10^12)
+
+instance CoArbitrary DiffTime where
coarbitrary t = coarbitrary (fromEnum t)
instance Arbitrary TimeOfDay where
arbitrary = liftM timeToTimeOfDay arbitrary
+
+instance CoArbitrary TimeOfDay where
coarbitrary t = coarbitrary (timeOfDayToTime t)
instance Arbitrary LocalTime where
arbitrary = liftM2 LocalTime arbitrary arbitrary
+
+instance CoArbitrary LocalTime where
coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer)
instance Arbitrary TimeZone where
arbitrary = liftM minutesToTimeZone $ choose (-720,720)
+
+instance CoArbitrary TimeZone where
coarbitrary tz = coarbitrary (timeZoneMinutes tz)
instance Arbitrary ZonedTime where
arbitrary = liftM2 ZonedTime arbitrary arbitrary
+
+instance CoArbitrary ZonedTime where
coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer)
instance Arbitrary UTCTime where
arbitrary = liftM2 UTCTime arbitrary arbitrary
+
+instance CoArbitrary UTCTime where
coarbitrary t = coarbitrary (truncate (utcTimeToPOSIXSeconds t) :: Integer)
-- missing from the time package
@@ -209,7 +217,7 @@ prop_fromSundayStartWeek d =
-- | Helper for defining named properties.
prop_named :: (Arbitrary t, Show t, Testable a)
=> String -> (FormatString s -> t -> a) -> String -> FormatString s -> NamedProperty
-prop_named name prop typeName f = (name ++ " " ++ typeName ++ " " ++ show f, property (prop f))
+prop_named n prop typeName f = (n ++ " " ++ typeName ++ " " ++ show f, property (prop f))
prop_parse_format :: (Eq t, FormatTime t, ParseTime t) => FormatString t -> t -> Bool
prop_parse_format (FormatString f) t = parse f (format f t) == Just t
@@ -255,6 +263,7 @@ instance Arbitrary Input where
arbitrary = liftM Input $ list cs
where cs = elements (['0'..'9'] ++ ['-',' ','/'] ++ ['a'..'z'] ++ ['A' .. 'Z'])
list g = sized (\n -> choose (0,n) >>= \l -> replicateM l g)
+instance CoArbitrary Input where
coarbitrary (Input s) = coarbitrary (sum (map ord s))
prop_no_crash_bad_input :: (Eq t, ParseTime t) => FormatString t -> Input -> Property
@@ -282,8 +291,6 @@ castFormatString (FormatString f) = FormatString f
instance Show (FormatString a) where
show (FormatString f) = show f
-type NamedProperty = (String, Property)
-
properties :: [NamedProperty]
properties =
[("prop_fromMondayStartWeek", property prop_fromMondayStartWeek),
diff --git a/Test/TestTime.hs b/Test/TestTime.hs
index cfa476b..86e9919 100644
--- a/Test/TestTime.hs
+++ b/Test/TestTime.hs
@@ -1,16 +1,11 @@
-{-# OPTIONS -Wall -Werror #-}
-
module Test.TestTime where
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time
-
import Test.TestUtil
import Test.TestTimeRef
---
-
showCal :: Integer -> String
showCal mjd
= let date = ModifiedJulianDay mjd
@@ -107,6 +102,5 @@ testTimeOfDayToDayFraction
, show $ f $ TimeOfDay 12 34 56.789123456789 ]
testTime :: Test
-testTime
- = Test $ pure "testTime"
- $ diff testTimeRef $ unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction]
+testTime = pureTest "testTime" $
+ diff testTimeRef $ unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction]
diff --git a/Test/TestUtil.hs b/Test/TestUtil.hs
index 88d95d2..de22be3 100644
--- a/Test/TestUtil.hs
+++ b/Test/TestUtil.hs
@@ -1,46 +1,43 @@
+{-# OPTIONS -fno-warn-overlapping-patterns #-}
module Test.TestUtil
- (
- module Test.TestUtil
- , module Distribution.TestSuite
- ) where
-
-import Distribution.TestSuite
-
-impure :: String -> IO Result -> TestInstance
-impure name mresult = TestInstance {
- run = fmap Finished mresult,
- name = name,
- tags = [],
- options = [],
- setOption = \_ _ -> Left "unsupported"
-}
-
-pure :: String -> Result -> TestInstance
-pure name result = impure name (return result)
-
-diff :: String -> String -> Result
-diff s t | s == t = Pass
-diff _ _ = 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 Result
-concatRun [] = return Pass
-concatRun (iop:iops) = do
- result <- finish iop
- case result of
- Pass -> concatRun iops
- _ -> return result
-
-concatTestInstance :: String -> [TestInstance] -> TestInstance
-concatTestInstance tname tis = impure tname (concatRun (fmap run tis))
-
-fastTestInstanceGroup :: String -> [TestInstance] -> Test
-fastTestInstanceGroup tname tis | False = testGroup tname (fmap Test tis)
-fastTestInstanceGroup tname tis = Test (concatTestInstance tname tis)
+ (
+ module Test.TestUtil,
+ module Test.Framework,
+ module Test.Framework.Providers.QuickCheck2
+ ) where
+import Test.Framework
+import Test.Framework.Providers.API
+import Test.Framework.Providers.QuickCheck2
+
+data Result = Pass | Fail String
+
+instance Show Result where
+ show Pass = "passed"
+ show (Fail s) = "failed: " ++ s
+
+instance TestResultlike () Result where
+ testSucceeded Pass = True
+ testSucceeded (Fail _) = False
+
+instance Testlike () Result (IO Result) where
+ testTypeName _ = "Cases"
+ runTest _ ior = do
+ r <- ior
+ return (Finished r,return ())
+
+ioTest :: String -> IO Result -> Test
+ioTest = Test
+
+pureTest :: String -> Result -> Test
+pureTest name result = ioTest name (return result)
+
+diff :: (Show a,Eq a) => a -> a -> Result
+diff expected found | expected == found = Pass
+diff expected found = Fail ("expected [" ++ (show expected) ++ "] but found [" ++ (show found) ++ "]")
+
+data ExhaustiveTest = forall t. (Show t) => MkExhaustiveTest String [t] (t -> IO Result)
+
+exhaustiveTestInstances :: ExhaustiveTest -> Test
+exhaustiveTestInstances (MkExhaustiveTest name cases f) = testGroup name (fmap toTI cases) where
+ toTI t = ioTest (show t) (f t)
diff --git a/Test/Tests.hs b/Test/Tests.hs
index 2185918..512b64e 100644
--- a/Test/Tests.hs
+++ b/Test/Tests.hs
@@ -1,6 +1,6 @@
module Test.Tests where
-import Distribution.TestSuite
+import Test.Framework
import Test.AddDays
import Test.ClipDates
@@ -11,10 +11,11 @@ import Test.TestEaster
import Test.TestFormat
import Test.TestMonthDay
import Test.TestParseDAT
+import Test.TestParseTime
import Test.TestTime
-tests :: IO [Test]
-tests = return [ addDaysTest
+tests :: [Test]
+tests = [ addDaysTest
, clipDates
, convertBack
, longWeekYears
@@ -23,4 +24,5 @@ tests = return [ addDaysTest
, testFormat
, testMonthDay
, testParseDAT
+ , testParseTime
, testTime ]
diff --git a/time.cabal b/time.cabal
index 6574f89..7254d3b 100644
--- a/time.cabal
+++ b/time.cabal
@@ -34,13 +34,17 @@ extra-tmp-files:
include/HsTimeConfig.h
library
- build-depends: base >= 4,
- deepseq >= 1.1,
- old-locale
+ build-depends:
+ base >= 4,
+ deepseq >= 1.1,
+ old-locale
ghc-options: -Wall
default-language: Haskell2010
if impl(ghc)
- default-extensions: Rank2Types DeriveDataTypeable StandaloneDeriving
+ default-extensions:
+ Rank2Types
+ DeriveDataTypeable
+ StandaloneDeriving
cpp-options: -DLANGUAGE_Rank2Types -DLANGUAGE_DeriveDataTypeable -DLANGUAGE_StandaloneDeriving
else
if impl(hugs)
@@ -85,58 +89,78 @@ library
HsTime.h
HsTimeConfig.h
-Test-Suite tests
- type: detailed-0.9
- test-module: Test.Tests
- default-language: Haskell2010
- default-extensions: Rank2Types, CPP, DeriveDataTypeable, StandaloneDeriving
- cpp-options: -DLANGUAGE_Rank2Types -DLANGUAGE_DeriveDataTypeable -DLANGUAGE_StandaloneDeriving
- c-sources: cbits/HsTime.c Test/TestFormatStuff.c
- include-dirs: include
- build-depends: base, deepseq, Cabal >= 1.16, old-locale, process
- other-modules:
- Test.TestTime
- Test.TestTimeRef
- Test.TestParseDAT
- Test.TAI_UTC_DAT
- Test.TestParseDAT_Ref
- Test.TestMonthDay
- Test.TestMonthDayRef
- Test.TestFormat
- Test.TestEaster
- Test.TestEasterRef
- Test.TestCalendars
- Test.TestCalendarsRef
- Test.LongWeekYears
- Test.LongWeekYearsRef
- Test.ConvertBack
- Test.ClipDates
- Test.ClipDatesRef
- Test.AddDays
- Test.AddDaysRef
- Test.TestUtil
+test-suite tests
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ default-extensions:
+ Rank2Types
+ CPP
+ DeriveDataTypeable
+ StandaloneDeriving
+ ExistentialQuantification
+ MultiParamTypeClasses
+ FlexibleInstances
+ UndecidableInstances
+ ScopedTypeVariables
+ cpp-options: -DLANGUAGE_Rank2Types -DLANGUAGE_DeriveDataTypeable -DLANGUAGE_StandaloneDeriving
+ ghc-options: -Wall
+ c-sources: cbits/HsTime.c Test/TestFormatStuff.c
+ include-dirs: include
+ build-depends:
+ base,
+ deepseq,
+ Cabal >= 1.16,
+ old-locale,
+ process,
+ QuickCheck >= 2.5.1,
+ test-framework >= 0.6.1,
+ test-framework-quickcheck2 >= 0.2.12
+ main-is: Test.hs
+ other-modules:
+ Test.Tests
+ Test.TestTime
+ Test.TestTimeRef
+ Test.TestParseDAT
+ Test.TAI_UTC_DAT
+ Test.TestParseDAT_Ref
+ Test.TestParseTime
+ Test.TestMonthDay
+ Test.TestMonthDayRef
+ Test.TestFormat
+ Test.TestEaster
+ Test.TestEasterRef
+ Test.TestCalendars
+ Test.TestCalendarsRef
+ Test.LongWeekYears
+ Test.LongWeekYearsRef
+ Test.ConvertBack
+ Test.ClipDates
+ Test.ClipDatesRef
+ Test.AddDays
+ Test.AddDaysRef
+ Test.TestUtil
- Data.Time.Calendar.Private,
- Data.Time.Calendar.Days,
- Data.Time.Calendar.Gregorian,
- Data.Time.Calendar.JulianYearDay,
- Data.Time.Clock.Scale,
- Data.Time.Clock.UTC,
- Data.Time.Clock.CTimeval,
- Data.Time.Clock.UTCDiff,
- Data.Time.LocalTime.TimeZone,
- Data.Time.LocalTime.TimeOfDay,
- Data.Time.LocalTime.LocalTime,
- Data.Time.Format.Parse
- Data.Time.Calendar,
- Data.Time.Calendar.MonthDay,
- Data.Time.Calendar.OrdinalDate,
- Data.Time.Calendar.WeekDate,
- Data.Time.Calendar.Julian,
- Data.Time.Calendar.Easter,
- Data.Time.Clock,
- Data.Time.Clock.POSIX,
- Data.Time.Clock.TAI,
- Data.Time.LocalTime,
- Data.Time.Format,
- Data.Time
+ Data.Time.Calendar.Private,
+ Data.Time.Calendar.Days,
+ Data.Time.Calendar.Gregorian,
+ Data.Time.Calendar.JulianYearDay,
+ Data.Time.Clock.Scale,
+ Data.Time.Clock.UTC,
+ Data.Time.Clock.CTimeval,
+ Data.Time.Clock.UTCDiff,
+ Data.Time.LocalTime.TimeZone,
+ Data.Time.LocalTime.TimeOfDay,
+ Data.Time.LocalTime.LocalTime,
+ Data.Time.Format.Parse
+ Data.Time.Calendar,
+ Data.Time.Calendar.MonthDay,
+ Data.Time.Calendar.OrdinalDate,
+ Data.Time.Calendar.WeekDate,
+ Data.Time.Calendar.Julian,
+ Data.Time.Calendar.Easter,
+ Data.Time.Clock,
+ Data.Time.Clock.POSIX,
+ Data.Time.Clock.TAI,
+ Data.Time.LocalTime,
+ Data.Time.Format,
+ Data.Time
--
GitLab