Skip to content

Commit

Permalink
Compiles
Browse files Browse the repository at this point in the history
  • Loading branch information
Tom Sydney Kerckhove committed Nov 2, 2023
1 parent 9c1bb55 commit 595e1e5
Show file tree
Hide file tree
Showing 18 changed files with 96 additions and 115 deletions.
2 changes: 2 additions & 0 deletions lib/Data/Time/Calendar/Month.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,8 @@ module Data.Time.Calendar.Month (
fromYearMonthValid,
pattern MonthDay,
fromMonthDayValid,
monthOfYearIndex,
parseMonthOfYearIndex,
) where

import Control.DeepSeq
Expand Down
2 changes: 0 additions & 2 deletions test/main/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@ import Test.Calendar.Duration
import Test.Calendar.Easter
import Test.Calendar.LongWeekYears
import Test.Calendar.MonthDay
import Test.Calendar.MonthOfYear
import Test.Calendar.Valid
import Test.Calendar.Week
import Test.Calendar.Year
Expand Down Expand Up @@ -42,7 +41,6 @@ tests =
, longWeekYears
, testDayPeriod
, testMonthDay
, testMonthOfYear
, testEaster
, testValid
, testWeek
Expand Down
9 changes: 7 additions & 2 deletions test/main/Test/Arbitrary.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,11 @@ instance Arbitrary FirstWeekType where

deriving instance Show FirstWeekType

instance Arbitrary MonthOfYear where
arbitrary = choose (1, 12) `suchThatMap` parseMonthOfYearIndex
shrink January = []
shrink _ = [January]

instance Arbitrary Month where
arbitrary = liftM MkMonth $ choose (-30000, 200000)

Expand All @@ -46,8 +51,8 @@ instance Arbitrary Day where
then [fromGregorian y m (d - 1)]
else []
monthShrink =
if m > 1
then [fromGregorian y (m - 1) d]
if m > January
then [fromGregorian y (pred m) d]
else []
yearShrink =
if y > 2000
Expand Down
4 changes: 3 additions & 1 deletion test/main/Test/Calendar/ClipDates.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,9 @@ module Test.Calendar.ClipDates (
clipDates,
) where

import Data.Maybe (fromJust)
import Data.Time.Calendar
import Data.Time.Calendar.Month
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Test.Calendar.ClipDatesRef
Expand All @@ -13,7 +15,7 @@ yearAndDay :: (Integer, Int) -> String
yearAndDay (y, d) = (show y) ++ "-" ++ (show d) ++ " = " ++ (showOrdinalDate (fromOrdinalDate y d))

gregorian :: (Integer, Int, Int) -> String
gregorian (y, m, d) = (show y) ++ "-" ++ (show m) ++ "-" ++ (show d) ++ " = " ++ (showGregorian (fromGregorian y m d))
gregorian (y, m, d) = (show y) ++ "-" ++ (show m) ++ "-" ++ (show d) ++ " = " ++ (showGregorian (fromGregorian y (fromJust (parseMonthOfYearIndex m)) d))

iSOWeekDay :: (Integer, Int, Int) -> String
iSOWeekDay (y, w, d) = (show y) ++ "-W" ++ (show w) ++ "-" ++ (show d) ++ " = " ++ (showWeekDate (fromWeekDate y w d))
Expand Down
2 changes: 1 addition & 1 deletion test/main/Test/Calendar/ConvertBack.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ checkers =
]

days :: [Day]
days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++ (fmap (\year -> (fromGregorian year 1 4)) [1980 .. 2000])
days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++ (fmap (\year -> (fromGregorian year January 4)) [1980 .. 2000])

convertBack :: TestTree
convertBack = testCase "convertBack" $ assertEqual "" "" $ concatMap (\ch -> concatMap ch days) checkers
2 changes: 1 addition & 1 deletion test/main/Test/Calendar/DayPeriod.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@ newtype WMonthOfYear = MkWMonthOfYear MonthOfYear
deriving (Eq, Show)

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

newtype WMonth = MkWMonth Month
deriving (Eq, Show)
Expand Down
30 changes: 15 additions & 15 deletions test/main/Test/Calendar/Duration.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ data AddDiff = MkAddDiff
{ adName :: String
, adAdd :: CalendarDiffDays -> Day -> Day
, adDifference :: Day -> Day -> CalendarDiffDays
, adFromYMD :: Integer -> Int -> Int -> Day
, adFromYMD :: Integer -> MonthOfYear -> Int -> Day
}

gregorianClip :: AddDiff
Expand Down Expand Up @@ -68,7 +68,7 @@ testPositiveDiffs =
"positive-diff"
$ fmap testPositiveDiff addDiffs

testSpecific :: AddDiff -> (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree
testSpecific :: AddDiff -> (Integer, MonthOfYear, Int) -> (Integer, MonthOfYear, Int) -> (Integer, Integer) -> TestTree
testSpecific MkAddDiff{..} (y2, m2, d2) (y1, m1, d1) (em, ed) = let
day1 = adFromYMD y1 m1 d1
day2 = adFromYMD y2 m2 d2
Expand All @@ -78,7 +78,7 @@ testSpecific MkAddDiff{..} (y2, m2, d2) (y1, m1, d1) (em, ed) = let
assertEqual "add" day2 $ adAdd found day1
assertEqual "diff" expected found

testSpecificPair :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> (Integer, Integer) -> TestTree
testSpecificPair :: (Integer, MonthOfYear, Int) -> (Integer, MonthOfYear, Int) -> (Integer, Integer) -> (Integer, Integer) -> TestTree
testSpecificPair day2 day1 clipD rollD =
testGroup
(show day2 ++ " - " ++ show day1)
Expand All @@ -92,18 +92,18 @@ testSpecifics :: TestTree
testSpecifics =
testGroup
"specific"
[ testSpecificPair (2017, 04, 07) (2017, 04, 07) (0, 0) (0, 0)
, testSpecific gregorianClip (2017, 04, 07) (2017, 04, 01) (0, 6)
, testSpecific gregorianClip (2017, 04, 01) (2017, 04, 07) (0, -6)
, testSpecific gregorianClip (2017, 04, 07) (2017, 02, 01) (2, 6)
, testSpecific gregorianClip (2017, 02, 01) (2017, 04, 07) (-2, -6)
, testSpecificPair (2000, 03, 01) (2000, 01, 30) (1, 1) (1, 0)
, testSpecificPair (2001, 03, 01) (2001, 01, 30) (1, 1) (0, 30)
, testSpecificPair (2001, 03, 01) (2000, 01, 30) (13, 1) (12, 30)
, testSpecificPair (2000, 03, 01) (2000, 01, 31) (1, 1) (0, 30)
, testSpecificPair (2001, 03, 01) (2001, 01, 31) (1, 1) (0, 29)
, testSpecificPair (2001, 03, 01) (2000, 01, 31) (13, 1) (12, 29)
, testSpecificPair (2001, 10, 01) (2001, 08, 31) (1, 1) (1, 0)
[ testSpecificPair (2017, April, 07) (2017, April, 07) (0, 0) (0, 0)
, testSpecific gregorianClip (2017, April, 07) (2017, April, 01) (0, 6)
, testSpecific gregorianClip (2017, April, 01) (2017, April, 07) (0, -6)
, testSpecific gregorianClip (2017, April, 07) (2017, February, 01) (2, 6)
, testSpecific gregorianClip (2017, February, 01) (2017, April, 07) (-2, -6)
, testSpecificPair (2000, March, 01) (2000, January, 30) (1, 1) (1, 0)
, testSpecificPair (2001, March, 01) (2001, January, 30) (1, 1) (0, 30)
, testSpecificPair (2001, March, 01) (2000, January, 30) (13, 1) (12, 30)
, testSpecificPair (2000, March, 01) (2000, January, 31) (1, 1) (0, 30)
, testSpecificPair (2001, March, 01) (2001, January, 31) (1, 1) (0, 29)
, testSpecificPair (2001, March, 01) (2000, January, 31) (13, 1) (12, 29)
, testSpecificPair (2001, October, 01) (2001, August, 31) (1, 1) (1, 0)
]

testDuration :: TestTree
Expand Down
2 changes: 1 addition & 1 deletion test/main/Test/Calendar/LongWeekYears.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ import Test.Tasty.HUnit

longYear :: Integer -> Bool
longYear year =
case toWeekDate (fromGregorian year 12 31) of
case toWeekDate (fromGregorian year December 31) of
(_, 53, _) -> True
_ -> False

Expand Down
26 changes: 0 additions & 26 deletions test/main/Test/Calendar/MonthOfYear.hs
View file

This file was deleted.

3 changes: 2 additions & 1 deletion test/main/Test/Calendar/Valid.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@ import Data.Time.Calendar.Julian
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.WeekDate
import Test.QuickCheck.Property
import Test.Arbitrary ()
import Test.Tasty
import Test.Tasty.QuickCheck hiding (reason)

Expand Down Expand Up @@ -81,7 +82,7 @@ newtype WMonthOfYear
deriving (Eq, Show)

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

newtype WDayOfMonth
= MkWDayOfMonth DayOfMonth
Expand Down
38 changes: 19 additions & 19 deletions test/main/Test/Calendar/Week.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ import Test.TestUtil
testDay :: TestTree
testDay =
nameTest "day" $ do
let day = fromGregorian 2018 1 9
let day = fromGregorian 2018 January 9
assertEqual "" (ModifiedJulianDay 58127) day
assertEqual "" (2018, 2, 2) $ toWeekDate day
assertEqual "" Tuesday $ dayOfWeek day
Expand Down Expand Up @@ -156,18 +156,18 @@ weekAllDaysTests =
[ nameTest "FirstDay is less than Day-DayOfWeek" $
assertEqual
""
[YearMonthDay 2023 12 31 .. YearMonthDay 2024 1 6]
(weekAllDays Sunday (YearMonthDay 2024 1 1))
[YearMonthDay 2023 December 31 .. YearMonthDay 2024 January 6]
(weekAllDays Sunday (YearMonthDay 2024 January 1))
, nameTest "FirstDay is equal to Day-DayOfWeek" $
assertEqual
""
[YearMonthDay 2024 2 26 .. YearMonthDay 2024 3 3]
(weekAllDays Monday (YearMonthDay 2024 2 26))
[YearMonthDay 2024 February 26 .. YearMonthDay 2024 March 3]
(weekAllDays Monday (YearMonthDay 2024 February 26))
, nameTest "FirstDay is greater than Day-DayOfWeek" $
assertEqual
""
[YearMonthDay 2022 2 15 .. YearMonthDay 2022 2 21]
(weekAllDays Tuesday (YearMonthDay 2022 2 21))
[YearMonthDay 2022 February 15 .. YearMonthDay 2022 February 21]
(weekAllDays Tuesday (YearMonthDay 2022 February 21))
]
]
where
Expand All @@ -188,18 +188,18 @@ weekFirstDayTests =
[ nameTest "FirstDay is less than Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 20)
(weekFirstDay Sunday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 20)
(weekFirstDay Sunday (YearMonthDay 2022 February 21))
, nameTest "FirstDay is equal to Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 21)
(weekFirstDay Monday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 21)
(weekFirstDay Monday (YearMonthDay 2022 February 21))
, nameTest "FirstDay is greater than Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 15)
(weekFirstDay Tuesday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 15)
(weekFirstDay Tuesday (YearMonthDay 2022 February 21))
]
]
where
Expand All @@ -211,18 +211,18 @@ weekLastDayTests =
[ nameTest "FirstDay is less than Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 26)
(weekLastDay Sunday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 26)
(weekLastDay Sunday (YearMonthDay 2022 February 21))
, nameTest "FirstDay is equal to Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 27)
(weekLastDay Monday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 27)
(weekLastDay Monday (YearMonthDay 2022 February 21))
, nameTest "FirstDay is greater than Day-DayOfWeek" $
assertEqual
""
(YearMonthDay 2022 2 21)
(weekLastDay Tuesday (YearMonthDay 2022 2 21))
(YearMonthDay 2022 February 21)
(weekLastDay Tuesday (YearMonthDay 2022 February 21))
]

testWeek :: TestTree
Expand Down
10 changes: 5 additions & 5 deletions test/main/Test/Clock/TAI.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,18 +10,18 @@ import Test.TestUtil

sampleLeapSecondMap :: LeapSecondMap
sampleLeapSecondMap d
| d < fromGregorian 1972 1 1 = Nothing
| d < fromGregorian 1972 January 1 = Nothing
sampleLeapSecondMap d
| d < fromGregorian 1972 7 1 = Just 10
| d < fromGregorian 1972 July 1 = Just 10
sampleLeapSecondMap d
| d < fromGregorian 1975 1 1 = Just 11
| d < fromGregorian 1975 January 1 = Just 11
sampleLeapSecondMap _ = Nothing

testTAI :: TestTree
testTAI =
testGroup "leap second transition" $ let
dayA = fromGregorian 1972 6 30
dayB = fromGregorian 1972 7 1
dayA = fromGregorian 1972 June 30
dayB = fromGregorian 1972 July 1
utcTime1 = UTCTime dayA 86399
utcTime2 = UTCTime dayA 86400
utcTime3 = UTCTime dayB 0
Expand Down
2 changes: 1 addition & 1 deletion test/main/Test/Format/Format.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,7 +57,7 @@ testCheckParse :: TestTree
testCheckParse = testGroup "checkParse" $ tgroup formats $ \fmt -> tgroup somestrings $ \str -> checkParse fmt str

days :: [Day]
days = [(fromGregorian 2018 1 5) .. (fromGregorian 2018 1 26)]
days = [(fromGregorian 2018 January 5) .. (fromGregorian 2018 January 26)]

testDayOfWeek :: TestTree
testDayOfWeek =
Expand Down
Loading

0 comments on commit 595e1e5

Please sign in to comment.