{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.GenValidity.Time.Calendar where

import Data.GenValidity
import Data.Time.Calendar
import Data.Validity.Time.Calendar ()
import Test.QuickCheck

instance GenValid Day where
  genValid :: Gen Day
genValid = Gen Day
uniformlyOneHundredYearsAround2020
  shrinkValid :: Day -> [Day]
shrinkValid (ModifiedJulianDay Integer
i) = Integer -> Day
ModifiedJulianDay forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => a -> [a]
shrinkValid Integer
i

uniformlyOneHundredYearsAround2020 :: Gen Day
uniformlyOneHundredYearsAround2020 :: Gen Day
uniformlyOneHundredYearsAround2020 = do
  Integer
y <- forall a. Random a => (a, a) -> Gen a
choose (Integer
1970, Integer
2070)
  Int
m <- forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
12)
  Int
d <- forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
31)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d

genSmartDayAround :: Day -> Gen Day
genSmartDayAround :: Day -> Gen Day
genSmartDayAround Day
d = forall a. [Gen a] -> Gen a
oneof [forall a. GenValid a => Gen a
genValid, Day -> Gen Day
genDayAround Day
d, Day -> Gen Day
genDayCloselyAround Day
d]

-- We cannot put this in 'GenValid Day' around 'today' because that would break reproducability
genDayAround :: Day -> Gen Day
genDayAround :: Day -> Gen Day
genDayAround Day
today = do
  let (Integer
thisYear, Int
_, Int
_) = Day -> (Integer, Int, Int)
toGregorian Day
today
  Integer
y <- forall a. Random a => (a, a) -> Gen a
choose (forall a. Enum a => a -> a
pred Integer
thisYear, forall a. Enum a => a -> a
succ Integer
thisYear)
  Int
m <- forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
12)
  Int
d <- forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
31)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d

genDayCloselyAround :: Day -> Gen Day
genDayCloselyAround :: Day -> Gen Day
genDayCloselyAround Day
today = forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
s -> do
  Int
diff <- forall a. Random a => (a, a) -> Gen a
choose (-Int
s, Int
s)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addDays (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
diff) Day
today

instance GenValid CalendarDiffDays where
  genValid :: Gen CalendarDiffDays
genValid = Integer -> Integer -> CalendarDiffDays
CalendarDiffDays forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. GenValid a => Gen a
genValid
  shrinkValid :: CalendarDiffDays -> [CalendarDiffDays]
shrinkValid (CalendarDiffDays Integer
m Integer
d) = [Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
m' Integer
d' | (Integer
m', Integer
d') <- forall a. GenValid a => a -> [a]
shrinkValid (Integer
m, Integer
d)]

instance GenValid DayOfWeek where
  genValid :: Gen DayOfWeek
genValid =
    forall a. [a] -> Gen a
elements
      [ DayOfWeek
Monday,
        DayOfWeek
Tuesday,
        DayOfWeek
Wednesday,
        DayOfWeek
Thursday,
        DayOfWeek
Friday,
        DayOfWeek
Saturday,
        DayOfWeek
Sunday
      ]

  -- It's hard to know how to shrink this, because there is no official start of the week.
  -- However, just as we would shrink MonthOfYear to January, we will shrink the days of the week to monday
  shrinkValid :: DayOfWeek -> [DayOfWeek]
shrinkValid DayOfWeek
Monday = []
  shrinkValid DayOfWeek
Tuesday = [DayOfWeek
Monday]
  shrinkValid DayOfWeek
Wednesday = [DayOfWeek
Monday, DayOfWeek
Tuesday]
  shrinkValid DayOfWeek
Thursday = [DayOfWeek
Monday, DayOfWeek
Tuesday, DayOfWeek
Wednesday]
  shrinkValid DayOfWeek
Friday = [DayOfWeek
Monday, DayOfWeek
Tuesday, DayOfWeek
Wednesday, DayOfWeek
Thursday]
  shrinkValid DayOfWeek
Saturday = [DayOfWeek
Monday, DayOfWeek
Tuesday, DayOfWeek
Wednesday, DayOfWeek
Thursday, DayOfWeek
Friday]
  shrinkValid DayOfWeek
Sunday = [DayOfWeek
Monday, DayOfWeek
Tuesday, DayOfWeek
Wednesday, DayOfWeek
Thursday, DayOfWeek
Friday, DayOfWeek
Saturday]