module Data.Time.Calendar.Gregorian (
Year,
pattern CommonEra,
pattern BeforeCommonEra,
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,
DayOfMonth,
toGregorian,
fromGregorian,
pattern YearMonthDay,
fromGregorianValid,
showGregorian,
gregorianMonthLength,
addGregorianMonthsClip,
addGregorianMonthsRollOver,
addGregorianYearsClip,
addGregorianYearsRollOver,
addGregorianDurationClip,
addGregorianDurationRollOver,
diffGregorianDurationClip,
diffGregorianDurationRollOver,
isLeapYear,
) where
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.Days
import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Private
import Data.Time.Calendar.Types
toGregorian :: Day -> (Year, MonthOfYear, DayOfMonth)
toGregorian date = (year, month, day)
where
(year, yd) = toOrdinalDate date
(month, day) = dayOfYearToMonthAndDay (isLeapYear year) yd
fromGregorian :: Year -> MonthOfYear -> DayOfMonth -> Day
fromGregorian year month day = fromOrdinalDate year (monthAndDayToDayOfYear (isLeapYear year) month day)
pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day
pattern YearMonthDay y m d <-
(toGregorian -> (y, m, d))
where
YearMonthDay y m d = fromGregorian y m d
fromGregorianValid :: Year -> MonthOfYear -> DayOfMonth -> Maybe Day
fromGregorianValid year month day = do
doy <- monthAndDayToDayOfYearValid (isLeapYear year) month day
fromOrdinalDateValid year doy
showGregorian :: Day -> String
showGregorian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d)
where
(y, m, d) = toGregorian date
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)
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)
addGregorianMonthsClip :: Integer -> Day -> Day
addGregorianMonthsClip n day = fromGregorian y m d
where
(y, m, d) = addGregorianMonths n day
addGregorianMonthsRollOver :: Integer -> Day -> Day
addGregorianMonthsRollOver n day = addDays (fromIntegral d 1) (fromGregorian y m 1)
where
(y, m, d) = addGregorianMonths n day
addGregorianYearsClip :: Integer -> Day -> Day
addGregorianYearsClip n = addGregorianMonthsClip (n * 12)
addGregorianYearsRollOver :: Integer -> Day -> Day
addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12)
addGregorianDurationClip :: CalendarDiffDays -> Day -> Day
addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day
addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day
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
ymdiff = ym2 ym1
ymAllowed =
if day2 >= day1
then
if d2 >= d1
then ymdiff
else ymdiff 1
else
if d2 <= d1
then ymdiff
else ymdiff + 1
dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver day2 day1 = let
(y1, m1, d1) = toGregorian day1
(y2, m2, d2) = toGregorian day2
ym1 = y1 * 12 + toInteger m1
ym2 = y2 * 12 + toInteger m2
ymdiff = ym2 ym1
ymAllowed =
if day2 >= day1
then
if d2 >= d1
then ymdiff
else ymdiff 1
else
if d2 <= d1
then ymdiff
else ymdiff + 1
dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
instance Show Day where
show = showGregorian
instance DayPeriod Year where
periodFirstDay y = YearMonthDay y January 1
periodLastDay y = YearMonthDay y December 31
dayPeriod (YearMonthDay y _ _) = y