WIP: Month of year type

lib/Data/Time/Calendar/Easter.hs

@@ -18,7 +18,7 @@ sundayAfter day = addDays (7 - (mod (toModifiedJulianDay day + 3) 7)) day
 
 -- | Given a year, find the Paschal full moon according to Orthodox Christian tradition
 orthodoxPaschalMoon :: Year -> Day
-orthodoxPaschalMoon year = addDays (-shiftedEpact) (fromJulian jyear 4 19)
+orthodoxPaschalMoon year = addDays (-shiftedEpact) (fromJulian jyear April 19)
   where
     shiftedEpact = mod (14 + 11 * (mod year 19)) 30
     jyear =
@@ -32,7 +32,7 @@ orthodoxEaster = sundayAfter . orthodoxPaschalMoon
 
 -- | Given a year, find the Paschal full moon according to the Gregorian method
 gregorianPaschalMoon :: Year -> Day
-gregorianPaschalMoon year = addDays (-adjustedEpact) (fromGregorian year 4 19)
+gregorianPaschalMoon year = addDays (-adjustedEpact) (fromGregorian year April 19)
   where
     century = (div year 100) + 1
     shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30

lib/Data/Time/Calendar/Gregorian.hs

@@ -44,6 +44,7 @@ module Data.Time.Calendar.Gregorian (
     isLeapYear,
 ) where
 
+import Data.Maybe (fromJust)
 import Data.Time.Calendar.CalendarDiffDays
 import Data.Time.Calendar.Days
 import Data.Time.Calendar.MonthDay
@@ -82,7 +83,7 @@ fromGregorianValid year month day = do
 
 -- | Show in ISO 8601 format (yyyy-mm-dd)
 showGregorian :: Day -> String
-showGregorian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d)
+showGregorian date = (show4 y) ++ "-" ++ (show2 (monthOfYearIndex m)) ++ "-" ++ (show2 d)
   where
     (y, m, d) = toGregorian date
 
@@ -91,13 +92,13 @@ gregorianMonthLength :: Year -> MonthOfYear -> DayOfMonth
 gregorianMonthLength year = monthLength (isLeapYear year)
 
 rolloverMonths :: (Year, Integer) -> (Year, MonthOfYear)
-rolloverMonths (y, m) = (y + (div (m - 1) 12), fromIntegral (mod (m - 1) 12) + 1)
+rolloverMonths (y, m) = (y + (div (m - 1) 12), fromJust (parseMonthOfYearIndex (fromIntegral (mod (m - 1) 12) + 1)))
 
 addGregorianMonths :: Integer -> Day -> (Year, MonthOfYear, DayOfMonth)
 addGregorianMonths n day = (y', m', d)
   where
     (y, m, d) = toGregorian day
-    (y', m') = rolloverMonths (y, fromIntegral m + n)
+    (y', m') = rolloverMonths (y, fromIntegral (monthOfYearIndex m) + n)
 
 -- | Add months, with days past the last day of the month clipped to the last day.
 -- For instance, 2005-01-30 + 1 month = 2005-02-28.
@@ -136,8 +137,8 @@ diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
 diffGregorianDurationClip day2 day1 = let
     (y1, m1, d1) = toGregorian day1
     (y2, m2, d2) = toGregorian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
+    ym1 = y1 * 12 + toInteger (monthOfYearIndex m1)
+    ym2 = y2 * 12 + toInteger (monthOfYearIndex m2)
     ymdiff = ym2 - ym1
     ymAllowed =
         if day2 >= day1
@@ -157,8 +158,8 @@ diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
 diffGregorianDurationRollOver day2 day1 = let
     (y1, m1, _) = toGregorian day1
     (y2, m2, _) = toGregorian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
+    ym1 = y1 * 12 + toInteger (monthOfYearIndex m1)
+    ym2 = y2 * 12 + toInteger (monthOfYearIndex m2)
     ymdiff = ym2 - ym1
     findpos mdiff = let
         dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1

lib/Data/Time/Calendar/Julian.hs

@@ -36,6 +36,7 @@ module Data.Time.Calendar.Julian (
     diffJulianDurationRollOver,
 ) where
 
+import Data.Maybe (fromJust)
 import Data.Time.Calendar.CalendarDiffDays
 import Data.Time.Calendar.Days
 import Data.Time.Calendar.JulianYearDay
@@ -74,7 +75,7 @@ fromJulianValid year month day = do
 
 -- | Show in ISO 8601 format (yyyy-mm-dd)
 showJulian :: Day -> String
-showJulian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d)
+showJulian date = (show4 y) ++ "-" ++ (show2 (monthOfYearIndex m)) ++ "-" ++ (show2 d)
   where
     (y, m, d) = toJulian date
 
@@ -83,13 +84,13 @@ julianMonthLength :: Year -> MonthOfYear -> DayOfMonth
 julianMonthLength year = monthLength (isJulianLeapYear year)
 
 rolloverMonths :: (Year, Integer) -> (Year, MonthOfYear)
-rolloverMonths (y, m) = (y + (div (m - 1) 12), fromIntegral (mod (m - 1) 12) + 1)
+rolloverMonths (y, m) = (y + (div (m - 1) 12), fromJust (parseMonthOfYearIndex (fromIntegral (mod (m - 1) 12) + 1)))
 
 addJulianMonths :: Integer -> Day -> (Year, MonthOfYear, DayOfMonth)
 addJulianMonths n day = (y', m', d)
   where
     (y, m, d) = toJulian day
-    (y', m') = rolloverMonths (y, fromIntegral m + n)
+    (y', m') = rolloverMonths (y, fromIntegral (monthOfYearIndex m) + n)
 
 -- | Add months, with days past the last day of the month clipped to the last day.
 -- For instance, 2005-01-30 + 1 month = 2005-02-28.
@@ -128,8 +129,8 @@ diffJulianDurationClip :: Day -> Day -> CalendarDiffDays
 diffJulianDurationClip day2 day1 = let
     (y1, m1, d1) = toJulian day1
     (y2, m2, d2) = toJulian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
+    ym1 = y1 * 12 + toInteger (monthOfYearIndex m1)
+    ym2 = y2 * 12 + toInteger (monthOfYearIndex m2)
     ymdiff = ym2 - ym1
     ymAllowed =
         if day2 >= day1
@@ -149,8 +150,8 @@ diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
 diffJulianDurationRollOver day2 day1 = let
     (y1, m1, _) = toJulian day1
     (y2, m2, _) = toJulian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
+    ym1 = y1 * 12 + toInteger (monthOfYearIndex m1)
+    ym2 = y2 * 12 + toInteger (monthOfYearIndex m2)
     ymdiff = ym2 - ym1
     findpos mdiff = let
         dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1

lib/Data/Time/Calendar/Month.hs

@@ -9,15 +9,19 @@
     fromYearMonthValid,
     pattern MonthDay,
     fromMonthDayValid,
+    monthOfYearIndex,
+    parseMonthOfYearIndex,
 ) where
 
 import Control.DeepSeq
 import Data.Data
 import Data.Fixed
 import Data.Ix
+import Data.Maybe (fromJust)
 import Data.Time.Calendar.Days
 import Data.Time.Calendar.Gregorian
 import Data.Time.Calendar.Private
+import Data.Time.Calendar.Types
 import qualified Language.Haskell.TH.Syntax as TH
 import Text.ParserCombinators.ReadP
 import Text.Read
@@ -48,19 +52,22 @@
 
 -- | Show as @yyyy-mm@.
 instance Show Month where
-    show (YearMonth y m) = show4 y ++ "-" ++ show2 m
+    show (YearMonth y m) = show4 y ++ "-" ++ show2 (monthOfYearIndex m)
 
 -- | Read as @yyyy-mm@.
 instance Read Month where
     readPrec = do
         y <- readPrec
         _ <- lift $ char '-'
-        m <- readPrec
-        return $ YearMonth y m
+        moy' <- readPrec
+        moy <- case parseMonthOfYearIndex moy' of
+          Nothing -> fail "Invalid month of year index"
+          Just moy -> pure moy
+        return $ YearMonth y moy
 
 instance DayPeriod Month where
     periodFirstDay (YearMonth y m) = YearMonthDay y m 1
     periodLastDay (YearMonth y m) = YearMonthDay y m 31 -- clips to correct day
     dayPeriod (YearMonthDay y my _) = YearMonth y my
 
 addMonths :: Integer -> Month -> Month
@@ -70,19 +77,17 @@
 diffMonths (MkMonth a) (MkMonth b) = a - b
 
 -- | Bidirectional abstract constructor.
--- Invalid months of year will be clipped to the correct range.
 pattern YearMonth :: Year -> MonthOfYear -> Month
 pattern YearMonth y my <-
-    MkMonth ((\m -> divMod' m 12) -> (y, succ . fromInteger -> my))
+    MkMonth ((\m -> divMod' m 12) -> (y, fromJust . parseMonthOfYearIndex . succ . fromInteger -> my))
     where
-        YearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my)
+        YearMonth y my = MkMonth $ (y * 12) + toInteger (monthOfYearIndex (pred my))
 
 fromYearMonthValid :: Year -> MonthOfYear -> Maybe Month
-fromYearMonthValid y my = do
-    my' <- clipValid 1 12 my
-    return $ YearMonth y my'
+fromYearMonthValid y moy = Just $ fromYearMonth y moy
 
-{-# COMPLETE YearMonth #-}
+fromYearMonth :: Year -> MonthOfYear -> Month
+fromYearMonth = YearMonth
 
 -- | Bidirectional abstract constructor.
 -- Invalid days of month will be clipped to the correct range.

lib/Data/Time/Calendar/MonthDay.hs

@@ -1,19 +1,7 @@
 {-# LANGUAGE Safe #-}
 
 module Data.Time.Calendar.MonthDay (
-    MonthOfYear,
-    pattern January,
-    pattern February,
-    pattern March,
-    pattern April,
-    pattern May,
-    pattern June,
-    pattern July,
-    pattern August,
-    pattern September,
-    pattern October,
-    pattern November,
-    pattern December,
+    MonthOfYear(..),
     DayOfMonth,
     DayOfYear,
     monthAndDayToDayOfYear,
@@ -30,11 +18,10 @@ import Data.Time.Calendar.Types
 monthAndDayToDayOfYear :: Bool -> MonthOfYear -> DayOfMonth -> DayOfYear
 monthAndDayToDayOfYear isLeap month day = (div (367 * month'' - 362) 12) + k + day'
   where
-    month' = clip 1 12 month
-    day' = fromIntegral (clip 1 (monthLength' isLeap month') day)
-    month'' = fromIntegral month'
+    day' = fromIntegral (clip 1 (monthLength isLeap month) day)
+    month'' = monthOfYearIndex month
     k =
-        if month' <= 2
+        if month <= February
             then 0
             else
                 if isLeap
@@ -45,13 +32,12 @@ monthAndDayToDayOfYear isLeap month day = (div (367 * month'' - 362) 12) + k + d
 -- First arg is leap year flag.
 monthAndDayToDayOfYearValid :: Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfYear
 monthAndDayToDayOfYearValid isLeap month day = do
-    month' <- clipValid 1 12 month
-    day' <- clipValid 1 (monthLength' isLeap month') day
+    day' <- clipValid 1 (monthLength isLeap month) day
     let
         day'' = fromIntegral day'
-        month'' = fromIntegral month'
+        month'' = monthOfYearIndex month
         k =
-            if month' <= 2
+            if month <= February
                 then 0
                 else
                     if isLeap
@@ -74,35 +60,27 @@ dayOfYearToMonthAndDay isLeap yd =
             yd
         )
 
-findMonthDay :: [Int] -> Int -> (Int, Int)
+findMonthDay :: [Int] -> Int -> (MonthOfYear, Int)
 findMonthDay (n : ns) yd
-    | yd > n = (\(m, d) -> (m + 1, d)) (findMonthDay ns (yd - n))
-findMonthDay _ yd = (1, yd)
+    | yd > n = (\(m, d) -> (succ m, d)) (findMonthDay ns (yd - n))
+findMonthDay _ yd = (January, yd)
 
 -- | The length of a given month in the Gregorian or Julian calendars.
 -- First arg is leap year flag.
 monthLength :: Bool -> MonthOfYear -> DayOfMonth
-monthLength isLeap month' = monthLength' isLeap (clip 1 12 month')
+monthLength isLeap month = case month of
+  January -> 31
+  February -> if isLeap then 29 else 28
+  March -> 31
+  April -> 30
+  May -> 31
+  June -> 30
+  July -> 31
+  August -> 31
+  September -> 30
+  October -> 31
+  November -> 30
+  December -> 31
 
-monthLength' :: Bool -> MonthOfYear -> DayOfMonth
-monthLength' isLeap month' = (monthLengths isLeap) !! (month' - 1)
-
-monthLengths :: Bool -> [DayOfMonth]
-monthLengths isleap =
-    [ 31
-    , if isleap
-        then 29
-        else 28
-    , 31
-    , 30
-    , 31
-    , 30
-    , 31
-    , 31
-    , 30
-    , 31
-    , 30
-    , 31
-    ]
-
--- J        F                   M  A  M  J  J  A  S  O  N  D
+monthLengths :: Bool -> [Int]
+monthLengths isLeap = map (monthLength isLeap) [minBound .. maxBound]

lib/Data/Time/Calendar/Quarter.hs

@@ -120,14 +120,14 @@
 
 -- | The 'QuarterOfYear' this 'MonthOfYear' is in.
 monthOfYearQuarter :: MonthOfYear -> QuarterOfYear
-monthOfYearQuarter my | my <= 3 = Q1
-monthOfYearQuarter my | my <= 6 = Q2
-monthOfYearQuarter my | my <= 9 = Q3
+monthOfYearQuarter my | my <= March = Q1
+monthOfYearQuarter my | my <= June = Q2
+monthOfYearQuarter my | my <= September = Q3
 monthOfYearQuarter _ = Q4
 
 -- | The 'Quarter' this 'Month' is in.
 monthQuarter :: Month -> Quarter
 monthQuarter (YearMonth y my) = YearQuarter y $ monthOfYearQuarter my
 
 -- | The 'Quarter' this 'Day' is in.
 dayQuarter :: Day -> Quarter