module Data.Time.Calendar.Gregorian
(
Year
, MonthOfYear
, DayOfMonth
, toGregorian
, fromGregorian
, pattern YearMonthDay
, fromGregorianValid
, showGregorian
, gregorianMonthLength
, addGregorianMonthsClip
, addGregorianMonthsRollOver
, addGregorianYearsClip
, addGregorianYearsRollOver
, addGregorianDurationClip
, addGregorianDurationRollOver
, diffGregorianDurationClip
, diffGregorianDurationRollOver
, isLeapYear
) where
import Data.Time.Calendar.Types
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
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
#if __GLASGOW_HASKELL__ >= 802
#endif
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