Week.hs

module Test.Calendar.Week
    ( testWeek
    ) where

import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Test.TestUtil
import Test.Tasty
import Test.Tasty.HUnit
import Test.Arbitrary ()

testDay :: TestTree
testDay =
    nameTest "day" $ do
        let day = fromGregorian 2018 1 9
        assertEqual "" (ModifiedJulianDay 58127) day
        assertEqual "" (2018, 2, 2) $ toWeekDate day
        assertEqual "" Tuesday $ dayOfWeek day

allDaysOfWeek :: [DayOfWeek]
allDaysOfWeek = [Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday]

testAllDays :: String -> (DayOfWeek -> IO ()) -> TestTree
testAllDays name f = nameTest name $ fmap (\wd -> nameTest (show wd) $ f wd) allDaysOfWeek

testSucc :: TestTree
testSucc = testAllDays "succ" $ \wd -> assertEqual "" (toEnum $ succ $ fromEnum wd) $ succ wd

testPred :: TestTree
testPred = testAllDays "pred" $ \wd -> assertEqual "" (toEnum $ pred $ fromEnum wd) $ pred wd

testSequences :: TestTree
testSequences =
    nameTest
        "sequence"
        [ nameTest "[Monday .. Sunday]" $ assertEqual "" allDaysOfWeek [Monday .. Sunday]
        , nameTest "[Wednesday .. Wednesday]" $ assertEqual "" [Wednesday] [Wednesday .. Wednesday]
        , nameTest "[Sunday .. Saturday]" $
          assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday]
        , nameTest "[Thursday .. Wednesday]" $
          assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday]
        , nameTest "[Tuesday ..]" $
          assertEqual
              ""
              [ Tuesday
              , Wednesday
              , Thursday
              , Friday
              , Saturday
              , Sunday
              , Monday
              , Tuesday
              , Wednesday
              , Thursday
              , Friday
              , Saturday
              , Sunday
              , Monday
              , Tuesday
              ] $
          take 15 [Tuesday ..]
        , nameTest "[Wednesday, Tuesday ..]" $
          assertEqual
              ""
              [ Wednesday
              , Tuesday
              , Monday
              , Sunday
              , Saturday
              , Friday
              , Thursday
              , Wednesday
              , Tuesday
              , Monday
              , Sunday
              , Saturday
              , Friday
              , Thursday
              , Wednesday
              ] $
          take 15 [Wednesday,Tuesday ..]
        , nameTest "[Sunday, Friday ..]" $
          assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $
          take 8 [Sunday,Friday ..]
        , nameTest "[Monday,Sunday .. Tuesday]" $
          assertEqual "" [Monday, Sunday, Saturday, Friday, Thursday, Wednesday, Tuesday] [Monday,Sunday .. Tuesday]
        , nameTest "[Thursday, Saturday .. Tuesday]" $
          assertEqual "" [Thursday, Saturday, Monday, Wednesday, Friday, Sunday, Tuesday] [Thursday,Saturday .. Tuesday]
        ]

testReadShow :: TestTree
testReadShow = testAllDays "read show" $ \wd -> assertEqual "" wd $ read $ show wd

prop_firstDayOfWeekOnAfter_onAfter :: DayOfWeek -> Day -> Bool
prop_firstDayOfWeekOnAfter_onAfter dw d = firstDayOfWeekOnAfter dw d >= d

prop_firstDayOfWeekOnAfter_Day :: DayOfWeek -> Day -> Bool
prop_firstDayOfWeekOnAfter_Day dw d = dayOfWeek (firstDayOfWeekOnAfter dw d) == dw

prop_toFromWeekCalendar :: FirstWeekType -> DayOfWeek -> Day -> Bool
prop_toFromWeekCalendar wt ws d = let
    (y,wy,dw) = toWeekCalendar wt ws d
    in fromWeekCalendar wt ws y wy dw == d

prop_weekChanges :: FirstWeekType -> DayOfWeek -> Day -> Bool
prop_weekChanges wt ws d = let
    (_,wy0,_) = toWeekCalendar wt ws d
    (_,wy1,dw) = toWeekCalendar wt ws $ succ d
    in if dw == ws then wy0 /= wy1 else wy0 == wy1

prop_weekYearWholeStart :: DayOfWeek -> Year -> Bool
prop_weekYearWholeStart ws y = let
    d = fromWeekCalendar FirstWholeWeek ws y 1 ws
    (y',dy) = toOrdinalDate d
    in y == y' && dy >= 1 && dy <= 7

prop_weekYearMostStart :: DayOfWeek -> Year -> Bool
prop_weekYearMostStart ws y = let
    d = fromWeekCalendar FirstMostWeek ws y 2 ws
    (y',dy) = toOrdinalDate d
    in y == y' && dy >= 5 && dy <= 11

testDiff :: TestTree
testDiff = nameTest "diff"
    [
        nameTest "Friday - Tuesday" $ assertEqual "" 3 $ dayOfWeekDiff Friday Tuesday,
        nameTest "Tuesday - Friday" $ assertEqual "" 4 $ dayOfWeekDiff Tuesday Friday,
        nameTest "firstDayOfWeekOnAfter_onAfter" prop_firstDayOfWeekOnAfter_onAfter,
        nameTest "firstDayOfWeekOnAfter_Day" prop_firstDayOfWeekOnAfter_Day,
        nameTest "toFromWeekCalendar" prop_toFromWeekCalendar,
        nameTest "weekChanges" prop_weekChanges,
        nameTest "weekYearWholeStart" prop_weekYearWholeStart,
        nameTest "weekYearMostStart" prop_weekYearMostStart
    ]

testWeek :: TestTree
testWeek = nameTest "Week" [testDay, testSucc, testPred, testSequences, testReadShow, testDiff]