Valid.hs

module Test.Calendar.Valid (
    testValid,
) where

import Data.Time
import Data.Time.Calendar.Julian
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Test.QuickCheck.Property
import Test.Tasty
import Test.Tasty.QuickCheck hiding (reason)

validResult :: (Eq c, Show c, Eq t, Show t) => (s -> c) -> Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> s -> Result
validResult sc valid toComponents fromComponents fromComponentsValid s =
    let c = sc s
        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 s, Show s, Eq c, Show c, Eq t, Show t) =>
    String ->
    (s -> c) ->
    (t -> c) ->
    (c -> t) ->
    (c -> Maybe t) ->
    TestTree
validTest name sc toComponents fromComponents fromComponentsValid =
    testGroup
        name
        [ testProperty "valid" $ property $ validResult sc True toComponents fromComponents fromComponentsValid
        , testProperty "invalid" $ property $ validResult sc False toComponents fromComponents fromComponentsValid
        ]

toSundayStartWeek :: Day -> (Integer, Int, Int)
toSundayStartWeek day =
    let (y, _) = toOrdinalDate day
        (w, d) = sundayStartWeek day
     in (y, w, d)

toMondayStartWeek :: Day -> (Integer, Int, Int)
toMondayStartWeek day =
    let (y, _) = toOrdinalDate day
        (w, d) = mondayStartWeek day
     in (y, w, d)

newtype WYear
    = MkWYear Year
    deriving (Eq, Show)

instance Arbitrary WYear where
    arbitrary = fmap MkWYear $ choose (-1000, 3000)

newtype WMonthOfYear
    = MkWMonthOfYear MonthOfYear
    deriving (Eq, Show)

instance Arbitrary WMonthOfYear where
    arbitrary = fmap MkWMonthOfYear $ choose (-5, 17)

newtype WDayOfMonth
    = MkWDayOfMonth DayOfMonth
    deriving (Eq, Show)

instance Arbitrary WDayOfMonth where
    arbitrary = fmap MkWDayOfMonth $ choose (-5, 35)

newtype WDayOfYear
    = MkWDayOfYear DayOfYear
    deriving (Eq, Show)

instance Arbitrary WDayOfYear where
    arbitrary = fmap MkWDayOfYear $ choose (-20, 400)

newtype WWeekOfYear
    = MkWWeekOfYear WeekOfYear
    deriving (Eq, Show)

instance Arbitrary WWeekOfYear where
    arbitrary = fmap MkWWeekOfYear $ choose (-5, 60)

newtype WDayOfWeek
    = MkWDayOfWeek Int
    deriving (Eq, Show)

instance Arbitrary WDayOfWeek where
    arbitrary = fmap MkWDayOfWeek $ choose (-5, 15)

fromYMD :: (WYear, WMonthOfYear, WDayOfMonth) -> (Year, MonthOfYear, DayOfMonth)
fromYMD (MkWYear y, MkWMonthOfYear ym, MkWDayOfMonth md) = (y, ym, md)

fromYD :: (WYear, WDayOfYear) -> (Year, DayOfYear)
fromYD (MkWYear y, MkWDayOfYear yd) = (y, yd)

fromYWD :: (WYear, WWeekOfYear, WDayOfWeek) -> (Year, WeekOfYear, Int)
fromYWD (MkWYear y, MkWWeekOfYear yw, MkWDayOfWeek wd) = (y, yw, wd)

testValid :: TestTree
testValid =
    testGroup
        "testValid"
        [ validTest
            "Gregorian"
            fromYMD
            toGregorian
            (\(y, m, d) -> fromGregorian y m d)
            (\(y, m, d) -> fromGregorianValid y m d)
        , validTest
            "OrdinalDate"
            fromYD
            toOrdinalDate
            (\(y, d) -> fromOrdinalDate y d)
            (\(y, d) -> fromOrdinalDateValid y d)
        , validTest
            "WeekDate"
            fromYWD
            toWeekDate
            (\(y, w, d) -> fromWeekDate y w d)
            (\(y, w, d) -> fromWeekDateValid y w d)
        , validTest
            "SundayStartWeek"
            fromYWD
            toSundayStartWeek
            (\(y, w, d) -> fromSundayStartWeek y w d)
            (\(y, w, d) -> fromSundayStartWeekValid y w d)
        , validTest
            "MondayStartWeek"
            fromYWD
            toMondayStartWeek
            (\(y, w, d) -> fromMondayStartWeek y w d)
            (\(y, w, d) -> fromMondayStartWeekValid y w d)
        , validTest "Julian" fromYMD toJulian (\(y, m, d) -> fromJulian y m d) (\(y, m, d) -> fromJulianValid y m d)
        ]