module Data.Time.Calendar.Julian
( module Data.Time.Calendar.JulianYearDay
, toJulian
, fromJulian
, 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
toJulian :: Day -> (Integer, Int, Int)
toJulian date = (year, month, day)
where
(year, yd) = toJulianYearAndDay date
(month, day) = dayOfYearToMonthAndDay (isJulianLeapYear year) yd
fromJulian :: Integer -> Int -> Int -> Day
fromJulian year month day = fromJulianYearAndDay year (monthAndDayToDayOfYear (isJulianLeapYear year) month day)
fromJulianValid :: Integer -> Int -> Int -> 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 :: Integer -> Int -> Int
julianMonthLength year = monthLength (isJulianLeapYear year)
rolloverMonths :: (Integer, Integer) -> (Integer, Int)
rolloverMonths (y, m) = (y + (div (m - 1) 12), fromIntegral (mod (m - 1) 12) + 1)
addJulianMonths :: Integer -> Day -> (Integer, Int, Int)
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