module Data.Time.Calendar.Julian (
Year,
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,
DayOfYear,
module Data.Time.Calendar.JulianYearDay,
toJulian,
fromJulian,
pattern JulianYearMonthDay,
fromJulianValid,
showJulian,
julianMonthLength,
addJulianMonthsClip,
addJulianMonthsRollOver,
addJulianYearsClip,
addJulianYearsRollOver,
addJulianDurationClip,
addJulianDurationRollOver,
diffJulianDurationClip,
diffJulianDurationRollOver,
) where
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.Days
import Data.Time.Calendar.JulianYearDay
import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.Private
import Data.Time.Calendar.Types
toJulian :: Day -> (Year, MonthOfYear, DayOfMonth)
toJulian date = (year, month, day)
where
(year, yd) = toJulianYearAndDay date
(month, day) = dayOfYearToMonthAndDay (isJulianLeapYear year) yd
fromJulian :: Year -> MonthOfYear -> DayOfMonth -> Day
fromJulian year month day = fromJulianYearAndDay year (monthAndDayToDayOfYear (isJulianLeapYear year) month day)
pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day
pattern JulianYearMonthDay y m d <-
(toJulian -> (y, m, d))
where
JulianYearMonthDay y m d = fromJulian y m d
fromJulianValid :: Year -> MonthOfYear -> DayOfMonth -> Maybe Day
fromJulianValid year month day = do
doy <- monthAndDayToDayOfYearValid (isJulianLeapYear year) month day
fromJulianYearAndDayValid year doy
showJulian :: Day -> String
showJulian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d)
where
(y, m, d) = toJulian date
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)
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)
addJulianMonthsClip :: Integer -> Day -> Day
addJulianMonthsClip n day = fromJulian y m d
where
(y, m, d) = addJulianMonths n day
addJulianMonthsRollOver :: Integer -> Day -> Day
addJulianMonthsRollOver n day = addDays (fromIntegral d 1) (fromJulian y m 1)
where
(y, m, d) = addJulianMonths n day
addJulianYearsClip :: Integer -> Day -> Day
addJulianYearsClip n = addJulianMonthsClip (n * 12)
addJulianYearsRollOver :: Integer -> Day -> Day
addJulianYearsRollOver n = addJulianMonthsRollOver (n * 12)
addJulianDurationClip :: CalendarDiffDays -> Day -> Day
addJulianDurationClip (CalendarDiffDays m d) day = addDays d $ addJulianMonthsClip m day
addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day
addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMonthsRollOver m day
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
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 = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver day2 day1 = let
(y1, m1, d1) = toJulian day1
(y2, m2, d2) = toJulian 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 = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed