[commit: packages/time] format-widths, tasty: test: TestValid: fix rejected cases problem (c9756f7)
git at git.haskell.org
git at git.haskell.org
Mon Feb 20 21:20:23 UTC 2017
Repository : ssh://git@git.haskell.org/time
On branches: format-widths,tasty
Link : http://git.haskell.org/packages/time.git/commitdiff/c9756f78625e0a1aa5247d97ed3ff85f4df94d75
>---------------------------------------------------------------
commit c9756f78625e0a1aa5247d97ed3ff85f4df94d75
Author: Ashley Yakeley <ashley at yakeley.org>
Date: Fri Feb 3 00:32:27 2017 -0800
test: TestValid: fix rejected cases problem
>---------------------------------------------------------------
c9756f78625e0a1aa5247d97ed3ff85f4df94d75
test/Test/TestValid.hs | 68 +++++++++++++++++++++++++++++++++++++-------------
1 file changed, 51 insertions(+), 17 deletions(-)
diff --git a/test/Test/TestValid.hs b/test/Test/TestValid.hs
index 6909425..4d8d18f 100644
--- a/test/Test/TestValid.hs
+++ b/test/Test/TestValid.hs
@@ -10,8 +10,9 @@ import Test.QuickCheck.Property
validResult :: (Eq c,Show c,Eq t,Show t) =>
- Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> c -> Result
-validResult valid toComponents fromComponents fromComponentsValid c = let
+ (s -> c) -> Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> s -> Result
+validResult sc valid toComponents fromComponents fromComponentsValid s = let
+ c = sc s
mt = fromComponentsValid c
t' = fromComponents c
c' = toComponents t'
@@ -29,33 +30,66 @@ validResult valid toComponents fromComponents fromComponentsValid c = let
else failed {reason = show c ++ " found invalid, but converts with " ++ show t'}
Just _ -> rejected
-validTest :: (Arbitrary c,Eq c,Show c,Eq t,Show t) =>
- String -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> TestTree
-validTest name toComponents fromComponents fromComponentsValid = testGroup name
+validTest :: (Arbitrary s,Show s,Eq c,Show c,Eq t,Show t) =>
+ String -> (s -> c) -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> TestTree
+validTest name sc toComponents fromComponents fromComponentsValid = testGroup name
[
- testProperty "valid" $ property $ validResult True toComponents fromComponents fromComponentsValid,
- testProperty "invalid" $ property $ validResult False toComponents fromComponents fromComponentsValid
+ testProperty "valid" $ property $ validResult sc True toComponents fromComponents fromComponentsValid,
+ testProperty "invalid" $ property $ validResult sc False toComponents fromComponents fromComponentsValid
]
toSundayStartWeek :: Day -> (Integer,Int,Int)
toSundayStartWeek day = let
(y,_) = toOrdinalDate day
- (m,d) = sundayStartWeek day
- in (y,m,d)
+ (w,d) = sundayStartWeek day
+ in (y,w,d)
toMondayStartWeek :: Day -> (Integer,Int,Int)
toMondayStartWeek day = let
(y,_) = toOrdinalDate day
- (m,d) = mondayStartWeek day
- in (y,m,d)
+ (w,d) = mondayStartWeek day
+ in (y,w,d)
+
+newtype Year = MkYear Integer deriving (Eq,Show)
+instance Arbitrary Year where
+ arbitrary = fmap MkYear $ choose (-1000,3000)
+
+newtype YearMonth = MkYearMonth Int deriving (Eq,Show)
+instance Arbitrary YearMonth where
+ arbitrary = fmap MkYearMonth $ choose (-5,17)
+
+newtype MonthDay = MkMonthDay Int deriving (Eq,Show)
+instance Arbitrary MonthDay where
+ arbitrary = fmap MkMonthDay $ choose (-5,35)
+
+newtype YearDay = MkYearDay Int deriving (Eq,Show)
+instance Arbitrary YearDay where
+ arbitrary = fmap MkYearDay $ choose (-20,400)
+
+newtype YearWeek = MkYearWeek Int deriving (Eq,Show)
+instance Arbitrary YearWeek where
+ arbitrary = fmap MkYearWeek $ choose (-5,60)
+
+newtype WeekDay = MkWeekDay Int deriving (Eq,Show)
+instance Arbitrary WeekDay where
+ arbitrary = fmap MkWeekDay $ choose (-5,15)
+
+fromYMD :: (Year,YearMonth,MonthDay) -> (Integer,Int,Int)
+fromYMD (MkYear y,MkYearMonth ym,MkMonthDay md) = (y,ym,md)
+
+fromYD :: (Year,YearDay) -> (Integer,Int)
+fromYD (MkYear y,MkYearDay yd) = (y,yd)
+
+fromYWD :: (Year,YearWeek,WeekDay) -> (Integer,Int,Int)
+fromYWD (MkYear y,MkYearWeek yw,MkWeekDay wd) = (y,yw,wd)
testValid :: TestTree
testValid = testGroup "testValid"
[
- validTest "Gregorian" toGregorian (\(y,m,d) -> fromGregorian y m d) (\(y,m,d) -> fromGregorianValid y m d),
- validTest "OrdinalDate" toOrdinalDate (\(y,d) -> fromOrdinalDate y d) (\(y,d) -> fromOrdinalDateValid y d),
- validTest "WeekDate" toWeekDate (\(y,m,d) -> fromWeekDate y m d) (\(y,m,d) -> fromWeekDateValid y m d),
- validTest "SundayStartWeek" toSundayStartWeek (\(y,m,d) -> fromSundayStartWeek y m d) (\(y,m,d) -> fromSundayStartWeekValid y m d),
- validTest "MondayStartWeek" toMondayStartWeek (\(y,m,d) -> fromMondayStartWeek y m d) (\(y,m,d) -> fromMondayStartWeekValid y m d),
- validTest "Julian" toJulian (\(y,m,d) -> fromJulian y m d) (\(y,m,d) -> fromJulianValid y m d)
+ validTest "Gregorian" fromYMD toGregorian (\(y,m,d) -> fromGregorian y m d) (\(y,m,d) -> fromGregorianValid y m d),
+ validTest "OrdinalDate" fromYD toOrdinalDate (\(y,d) -> fromOrdinalDate y d) (\(y,d) -> fromOrdinalDateValid y d),
+ validTest "WeekDate" fromYWD toWeekDate (\(y,w,d) -> fromWeekDate y w d) (\(y,w,d) -> fromWeekDateValid y w d),
+ validTest "SundayStartWeek" fromYWD toSundayStartWeek (\(y,w,d) -> fromSundayStartWeek y w d) (\(y,w,d) -> fromSundayStartWeekValid y w d),
+ validTest "MondayStartWeek" fromYWD toMondayStartWeek (\(y,w,d) -> fromMondayStartWeek y w d) (\(y,w,d) -> fromMondayStartWeekValid y w d),
+ validTest "Julian" fromYMD toJulian (\(y,m,d) -> fromJulian y m d) (\(y,m,d) -> fromJulianValid y m d)
]
More information about the ghc-commits
mailing list