1module Test.Calendar.Valid(testValid) where 2 3import Data.Time.Compat 4import Data.Time.Calendar.OrdinalDate.Compat 5import Data.Time.Calendar.WeekDate.Compat 6import Data.Time.Calendar.Julian.Compat 7 8import Test.Tasty 9import Test.Tasty.QuickCheck hiding (reason) 10import Test.QuickCheck.Property 11 12 13validResult :: (Eq c,Show c,Eq t,Show t) => 14 (s -> c) -> Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> s -> Result 15validResult sc valid toComponents fromComponents fromComponentsValid s = let 16 c = sc s 17 mt = fromComponentsValid c 18 t' = fromComponents c 19 c' = toComponents t' 20 in if valid then 21 case mt of 22 Nothing -> rejected 23 Just t -> if t' /= t 24 then failed {reason = "'fromValid' gives " ++ show t ++ ", but 'from' gives " ++ show t'} 25 else if c' /= c 26 then failed {reason = "found valid, but converts " ++ show c ++ " -> " ++ show t' ++ " -> " ++ show c'} 27 else succeeded 28 else case mt of 29 Nothing -> if c' /= c 30 then succeeded 31 else failed {reason = show c ++ " found invalid, but converts with " ++ show t'} 32 Just _ -> rejected 33 34validTest :: (Arbitrary s,Show s,Eq c,Show c,Eq t,Show t) => 35 String -> (s -> c) -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> TestTree 36validTest name sc toComponents fromComponents fromComponentsValid = testGroup name 37 [ 38 testProperty "valid" $ property $ validResult sc True toComponents fromComponents fromComponentsValid, 39 testProperty "invalid" $ property $ validResult sc False toComponents fromComponents fromComponentsValid 40 ] 41 42toSundayStartWeek :: Day -> (Integer,Int,Int) 43toSundayStartWeek day = let 44 (y,_) = toOrdinalDate day 45 (w,d) = sundayStartWeek day 46 in (y,w,d) 47 48toMondayStartWeek :: Day -> (Integer,Int,Int) 49toMondayStartWeek day = let 50 (y,_) = toOrdinalDate day 51 (w,d) = mondayStartWeek day 52 in (y,w,d) 53 54newtype Year = MkYear Integer deriving (Eq,Show) 55instance Arbitrary Year where 56 arbitrary = fmap MkYear $ choose (-1000,3000) 57 58newtype YearMonth = MkYearMonth Int deriving (Eq,Show) 59instance Arbitrary YearMonth where 60 arbitrary = fmap MkYearMonth $ choose (-5,17) 61 62newtype MonthDay = MkMonthDay Int deriving (Eq,Show) 63instance Arbitrary MonthDay where 64 arbitrary = fmap MkMonthDay $ choose (-5,35) 65 66newtype YearDay = MkYearDay Int deriving (Eq,Show) 67instance Arbitrary YearDay where 68 arbitrary = fmap MkYearDay $ choose (-20,400) 69 70newtype YearWeek = MkYearWeek Int deriving (Eq,Show) 71instance Arbitrary YearWeek where 72 arbitrary = fmap MkYearWeek $ choose (-5,60) 73 74newtype WeekDay = MkWeekDay Int deriving (Eq,Show) 75instance Arbitrary WeekDay where 76 arbitrary = fmap MkWeekDay $ choose (-5,15) 77 78fromYMD :: (Year,YearMonth,MonthDay) -> (Integer,Int,Int) 79fromYMD (MkYear y,MkYearMonth ym,MkMonthDay md) = (y,ym,md) 80 81fromYD :: (Year,YearDay) -> (Integer,Int) 82fromYD (MkYear y,MkYearDay yd) = (y,yd) 83 84fromYWD :: (Year,YearWeek,WeekDay) -> (Integer,Int,Int) 85fromYWD (MkYear y,MkYearWeek yw,MkWeekDay wd) = (y,yw,wd) 86 87testValid :: TestTree 88testValid = testGroup "testValid" 89 [ 90 validTest "Gregorian" fromYMD toGregorian (\(y,m,d) -> fromGregorian y m d) (\(y,m,d) -> fromGregorianValid y m d), 91 validTest "OrdinalDate" fromYD toOrdinalDate (\(y,d) -> fromOrdinalDate y d) (\(y,d) -> fromOrdinalDateValid y d), 92 validTest "WeekDate" fromYWD toWeekDate (\(y,w,d) -> fromWeekDate y w d) (\(y,w,d) -> fromWeekDateValid y w d), 93 validTest "SundayStartWeek" fromYWD toSundayStartWeek (\(y,w,d) -> fromSundayStartWeek y w d) (\(y,w,d) -> fromSundayStartWeekValid y w d), 94 validTest "MondayStartWeek" fromYWD toMondayStartWeek (\(y,w,d) -> fromMondayStartWeek y w d) (\(y,w,d) -> fromMondayStartWeekValid y w d), 95 validTest "Julian" fromYMD toJulian (\(y,m,d) -> fromJulian y m d) (\(y,m,d) -> fromJulianValid y m d) 96 ] 97