GregorianTest.hs

{-# LANGUAGE FlexibleContexts #-}    -- for the polymorphic 'ymd' helper's Enum (MoY d) constraint
module HodaTime.Calendar.GregorianTest
(
  gregorianTests
)
where

import Test.Tasty
import Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit
import Data.Maybe (fromJust, catMaybes)
import Data.Time.Calendar (fromGregorianValid, toGregorian)

import HodaTime.Util
import Data.HodaTime.CalendarDate (day, month, year, next, previous, dayOfWeek, DayNth(..), HasDate, MoY)
import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..))
import qualified Data.HodaTime.Calendar.Gregorian as G
import qualified Data.HodaTime.Calendar.Iso as Iso
import Data.HodaTime.Period (applyPeriod, days, months, years)

gregorianTests :: TestTree
gregorianTests = testGroup "Gregorian Tests" [qcProps, unitTests]

qcProps :: TestTree
qcProps = testGroup "(checked by QuickCheck)" [constructorProps, periodProps, nthDayProps]

unitTests :: TestTree
unitTests = testGroup "Unit tests" [constructorUnits, periodUnits, boundaryUnits]

-- | Decode a date to (day, 1-based month, year) for explicit expected-value assertions.
ymd :: (HasDate d, Enum (MoY d)) => d -> (Int, Int, Int)
ymd x = (day x, succ . fromEnum $ month x, year x)

-- | Hardcoded boundary regression tests for the Gregorian cycle representation.  These are the discrete,
--   known-tricky transitions (century edges, the cycle edge / extra leap day, and the 1582 validity threshold)
--   that the random generators in the 1900-2040 range never reach.
boundaryUnits :: TestTree
boundaryUnits = testGroup "Gregorian boundaries"
  [
  -- century edge: 2100 is NOT a leap year
     testCase "28 Feb 2100 constructs correctly" $ (ymd <$> calendarDate 28 February 2100) @?= Just (28, 2, 2100)
    ,testCase "29 Feb 2100 is invalid (2100 not leap)" $ calendarDate 29 February 2100 @?= Nothing
    ,testCase "31 Dec 2099 + 1 day == 1 Jan 2100" $ (ymd . applyPeriod (days 1) <$> calendarDate 31 December 2099) @?= Just (1, 1, 2100)
    ,testCase "1 Jan 2100 - 1 day == 31 Dec 2099" $ (ymd . applyPeriod (days (-1)) <$> calendarDate 1 January 2100) @?= Just (31, 12, 2099)
    ,testCase "28 Feb 2100 + 1 day == 1 Mar 2100" $ (ymd . applyPeriod (days 1) <$> calendarDate 28 February 2100) @?= Just (1, 3, 2100)
  -- cycle edge: 2400 IS a leap year; 29 Feb 2400 is the extra-cycle-day
    ,testCase "29 Feb 2400 constructs correctly (extra-cycle-day)" $ (ymd <$> calendarDate 29 February 2400) @?= Just (29, 2, 2400)
    ,testCase "28 Feb 2400 + 1 day == 29 Feb 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 28 February 2400) @?= Just (29, 2, 2400)
    ,testCase "29 Feb 2400 + 1 day == 1 Mar 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 29 February 2400) @?= Just (1, 3, 2400)
    ,testCase "31 Dec 2399 + 1 day == 1 Jan 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 31 December 2399) @?= Just (1, 1, 2400)
    ,testCase "29 Feb 2400 + 1 year clamps to 28 Feb 2401" $ (ymd . applyPeriod (years 1) <$> calendarDate 29 February 2400) @?= Just (28, 2, 2401)
  -- 1582 validity threshold: 15 Oct 1582 is the first valid Gregorian date
    ,testCase "1 Oct 1582 is invalid" $ calendarDate 1 October 1582 @?= Nothing
    ,testCase "15 Oct 1582 constructs correctly" $ (ymd <$> calendarDate 15 October 1582) @?= Just (15, 10, 1582)
    ,testCase "16 Oct 1582 - 1 day == 15 Oct 1582" $ (ymd . applyPeriod (days (-1)) <$> calendarDate 16 October 1582) @?= Just (15, 10, 1582)
  ]

constructorProps :: TestTree
constructorProps = testGroup "Constructor"
  [
    QC.testProperty "same dates as Data.Time" $ testConstructor
  ]
    where
      areSame Nothing Nothing = True
      areSame (Just hdate) (Just date) =
        let
          (ty, tm, tday) = toGregorian date
        in day hdate == tday && (convertMonth . month $ hdate) == tm && year hdate == (fromIntegral ty)
      areSame _ _ = False
      convertMonth = succ . fromEnum
      testConstructor (Positive y) m (Positive d) = areSame (calendarDate d m y') (fromGregorianValid (fromIntegral y') (convertMonth m) d)
        where
          y' = 1900 + y

periodProps :: TestTree
periodProps = testGroup "Period"
  [
     QC.testProperty "first day not changed by month math" $ testMonthAdd 1
    ,QC.testProperty "mid day not changed by month math" $ testMonthAdd 15
    ,QC.testProperty "dayOfWeek . next n dow $ date == dow" $ testNextDoW
    ,QC.testProperty "next n (dayOfWeek date) date == a positive day period" $ testDirection next id
    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate
    ,QC.testProperty "next 1 dow date < date + 8 days" $ testDirectionRange next (<) id
    ,QC.testProperty "previous 1 dow date > date - 8 days" $ testDirectionRange previous (>) negate
  ]
  where
    mkcd d m = fromJust . calendarDate d m
    testMonthAdd d (CycleYear y) m add = day (applyPeriod (months add) $ mkcd d m (y + 1900)) == d
    testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow
    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) epochDay
    testDirectionRange dir gtlt adjust dow (RandomStandardDate y m d) = let cd = mkcd d m y in dir 1 dow cd `gtlt` applyPeriod (days (adjust 8)) cd
    epochDay = mkcd 1 March 2000

nthDayProps :: TestTree
nthDayProps = testGroup "fromNthDay / fromWeekDate"
  [
     QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst
    ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast
    ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW
  ]
  where
    testFirst dow (RandomStandardDate y m _) =
      let r = fromNthDay First dow m y
      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && day d <= 7) r
    testLast dow (RandomStandardDate y m _) =
      let r = fromNthDay Last dow m y
      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 22) r
    testWeekDoW dow (RandomStandardDate y _ _) (Positive w) =
      maybe True ((== dow) . dayOfWeek) (G.fromWeekDate (1 + w `mod` 50) dow y)

constructorUnits :: TestTree
constructorUnits = testGroup "Constructor"
  [
     testCase "CalendarDate 30 February 2000 is not a valid date" $ calendarDate 30 February 2000 @?= Nothing
    ,testCase "CalendarDate 1 October 1582 is not a valid date" $ calendarDate 1 October 1582 @?= Nothing
    ,testCase "Gregorian.fromWeekDate 1 Sunday 2000 = 26.Dec.1999" $ G.fromWeekDate 1 Sunday 2000 @?= calendarDate 26 December 1999
    ,testCase "Gregorian.fromWeekDate 5 Sunday 2000 = 23.Jan.2000" $ G.fromWeekDate 5 Sunday 2000 @?= calendarDate 23 January 2000
    ,testCase "Iso.fromWeekDate 1 Sunday 2000 = 9.Jan.2000" $ Iso.fromWeekDate 1 Sunday 2000 @?= calendarDate 9 January 2000
    ,testCase "Iso.fromWeekDate 5 Sunday 2000 = 6.Feb.2000" $ Iso.fromWeekDate 5 Sunday 2000 @?= calendarDate 6 February 2000
    ,testCase "Holidays in year 2000" $ test2k (usaHolidays 2000)
    ,testCase "Holidays in year 2001" $ test2001 (usaHolidays 2001)
    ,testCase "Holidays in year 1582" $ test1582 (usaHolidays 1582)
    ,testCase "fromNthDay Last, when the month ends on that weekday, is the last day (not a week early)" $
       let lastDay = fromJust $ calendarDate 31 December 2000    -- 31.Dec.2000 is a Sunday
       in fromNthDay Last (dayOfWeek lastDay) December 2000 @?= Just lastDay
  ]
    where
      test2k hs = do
        assertEqual "length == 8" 8 (length hs)
        assertEqual "First Monday Sept = 4.Sept.2000" (fromJust $ calendarDate 4 September 2000) (hs !! 3)
        assertEqual "Third Monday Jan = 17.Jan.2000" (fromJust $ calendarDate 17 January 2000) (hs !! 4)
        assertEqual "Second Tuesday Feb = 8.Feb.2000" (fromJust $ calendarDate 8 February 2000) (hs !! 5)
        assertEqual "Fourth Thursday Nov = 23.Nov.2000" (fromJust $ calendarDate 23 November 2000) (hs !! 6)
      test2001 hs = do
        assertEqual "length == 7" 7 (length hs)
        assertEqual "First Monday Sept = 3.Sept.2001" (fromJust $ calendarDate 3 September 2001) (hs !! 3)
        assertEqual "Third Monday Jan = 15.Jan.2001" (fromJust $ calendarDate 15 January 2001) (hs !! 4)
        assertEqual "Second Tuesday Feb = 13.Feb.2001" (fromJust $ calendarDate 13 February 2001) (hs !! 5)
        assertEqual "Fourth Thursday Nov = 22.Nov.2001" (fromJust $ calendarDate 22 November 2001) (hs !! 6)
      test1582 hs = do
        assertEqual "length == 2" 2 (length hs)
        assertEqual "Fourth Thursday Nov = 25.Nov.1582" (fromJust $ calendarDate 25 November 1582) (hs !! 1)
      usaHolidays y = catMaybes $ ($ y) <$>
        [
           calendarDate 1 January               -- New Year
          ,calendarDate 4 July                  -- Independence Day 
          ,calendarDate 25 December             -- Christmas
          ,fromNthDay First Monday September    -- Labor day
          ,fromNthDay Third Monday January      -- MLK day
          ,fromNthDay Second Tuesday February   -- Presidents day
          ,fromNthDay Fourth Thursday November  -- Thanksgiving
          ,calendarDate 29 February             -- Not a holiday but will sometimes be absent
        ]

periodUnits :: TestTree
periodUnits = testGroup "Period"
  [
     testCase "31-January-2000 + 2M == 31-March-2000" $ applyPeriod (months 2) <$> janEnd @?= calendarDate 31 March 2000
    ,testCase "31-January-2000 + 1M == 29-February-2000" $ applyPeriod (months 1) <$> janEnd @?= calendarDate 29 February 2000
    ,testCase "15-November-1582 - 1M == 15-October-1582" $ applyPeriod (months (-1)) <$> calendarDate 15 November 1582 @?= firstValidDate
    ,testCase "14-November-1582 - 1M == 15-October-1582 (clamped)" $ applyPeriod (months (-1)) <$> calendarDate 14 November 1582 @?= firstValidDate
    ,testCase "29-February-2000 + 1Y == 28-February-2001" $ applyPeriod (years 1) <$> leapFeb @?= calendarDate 28 February 2001
    ,testCase "15-October-1583 - 1Y == 15-October-1582" $ applyPeriod (years (-1)) <$> calendarDate 15 October 1583 @?= firstValidDate
    ,testCase "14-October-1583 - 1Y == 15-October-1582 (clamped)" $ applyPeriod (years (-1)) <$> calendarDate 14 October 1583 @?= firstValidDate
    ,testCase "31-December-2000 + 1D == 1-January-2001" $ applyPeriod (days 1) <$> endYear @?= calendarDate 1 January 2001
    ,testCase "16-October-1583 - 1D == 15-October-1582" $ applyPeriod (days (-1)) <$> calendarDate 16 October 1582 @?= firstValidDate
    ,testCase "15-October-1583 - 1D == 15-October-1582 (clamped)" $ applyPeriod (days (-1)) <$> calendarDate 15 October 1582 @?= firstValidDate
  ]
    where
      janEnd = calendarDate 31 January 2000
      leapFeb = calendarDate 29 February 2000
      endYear = calendarDate 31 December 2000
      firstValidDate = calendarDate 15 October 1582