[commit: packages/time] format-widths, tasty: test: TestValid: fix rejected cases problem (c9756f7)

[git at git.haskell.org]

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)
     ]