datepicker

 1{-# OPTIONS_GHC -fno-warn-orphans #-}
 2
 3module QuickCheck (quickTests) where
 4
 5import Data.List.NonEmpty qualified as NE
 6import Data.Time.Calendar qualified as Cal
 7import Data.Time.Calendar.Month
 8import DatePicker.Util
 9import Test.Tasty
10import Test.Tasty.QuickCheck
11  ( Arbitrary,
12    arbitrary,
13    chooseEnum,
14    chooseInteger,
15    testProperty,
16  )
17
18instance Arbitrary Month where
19  arbitrary = do
20    m <- chooseInteger (1, 12)
21    y <- chooseInteger (0, 2030)
22    pure $ MkMonth ((y * 12) + (m - 1))
23
24instance Arbitrary Cal.DayOfWeek where
25  arbitrary = chooseEnum (Cal.Monday, Cal.Sunday)
26
27weekList :: Month -> NE.NonEmpty Cal.Day
28weekList m =
29  NE.fromList $ concatMap NE.toList (monthWeeks m Cal.Monday)
30
31------------------------------------------------------------------------
32
33monthWeeksAmount :: TestTree
34monthWeeksAmount =
35  testProperty
36    "week amount >= 4"
37    (\m -> NE.length (monthWeeks (m :: Month) Cal.Sunday) >= 4)
38
39monthWeeksOrdered :: TestTree
40monthWeeksOrdered =
41  testProperty "weeks of month are ordered properly" propOrdered
42  where
43    equalsDays :: Month -> [Integer] -> [Cal.Day] -> Bool
44    equalsDays m nth days =
45      let fstDay = Cal.periodFirstDay m
46       in all (\(d, n) -> Cal.addDays n fstDay == d) (zip days nth)
47
48    propOrdered :: Month -> Bool
49    propOrdered m = equalsDays m [0 ..] (NE.toList $ weekList m)
50
51monthWeeksBoundaries :: TestTree
52monthWeeksBoundaries =
53  testProperty "first/last day of month in weeks" propBoundary
54  where
55    propBoundary :: Month -> Bool
56    propBoundary m =
57      let w = weekList m
58       in NE.head w == Cal.periodFirstDay m
59            && NE.last w == Cal.periodLastDay m
60
61monthWeekStartOfWeek :: TestTree
62monthWeekStartOfWeek = testProperty "start of week" propWeekStart
63  where
64    propWeekStart :: Month -> Cal.DayOfWeek -> Bool
65    propWeekStart m dw =
66      all (\week -> Cal.dayOfWeek (NE.head week) == dw) $
67        NE.tail (monthWeeks m dw) -- Doesn't hold for first week
68
69quickTests :: TestTree
70quickTests =
71  testGroup
72    "QuickCheck Tests"
73    [ monthWeeksAmount,
74      monthWeeksOrdered,
75      monthWeeksBoundaries,
76      monthWeekStartOfWeek
77    ]