1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
module Test.TestValid where
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.Julian
import Test.QuickCheck hiding (Result,reason)
import Test.QuickCheck.Property
import Test.TestUtil hiding (Result)
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
mt = fromComponentsValid c
t' = fromComponents c
c' = toComponents t'
in if valid then
case mt of
Nothing -> rejected
Just t -> if t' /= t
then failed {reason = "'fromValid' gives " ++ show t ++ ", but 'from' gives " ++ show t'}
else if c' /= c
then failed {reason = "found valid, but converts " ++ show c ++ " -> " ++ show t' ++ " -> " ++ show c'}
else succeeded
else case mt of
Nothing -> if c' /= c
then succeeded
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) -> Test
validTest name toComponents fromComponents fromComponentsValid = testGroup name
[
testProperty "valid" $ property $ validResult True toComponents fromComponents fromComponentsValid,
testProperty "invalid" $ property $ validResult False toComponents fromComponents fromComponentsValid
]
toSundayStartWeek :: Day -> (Integer,Int,Int)
toSundayStartWeek day = let
(y,_) = toOrdinalDate day
(m,d) = sundayStartWeek day
in (y,m,d)
toMondayStartWeek :: Day -> (Integer,Int,Int)
toMondayStartWeek day = let
(y,_) = toOrdinalDate day
(m,d) = mondayStartWeek day
in (y,m,d)
testValid :: Test
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)
]
|
