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