{-# LANGUAGE Safe #-}

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,

    -- * Year and day format
    module Data.Time.Calendar.JulianYearDay,
    toJulian,
    fromJulian,
    pattern JulianYearMonthDay,
    fromJulianValid,
    showJulian,
    julianMonthLength,
    -- calendrical arithmetic
    -- e.g. "one month after March 31st"
    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

-- | Convert to proleptic Julian calendar.
toJulian :: Day -> (Year, MonthOfYear, DayOfMonth)
toJulian :: Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
date = (Year
year, MonthOfYear
month, MonthOfYear
day)
  where
    (Year
year, MonthOfYear
yd) = Day -> (Year, MonthOfYear)
toJulianYearAndDay Day
date
    (MonthOfYear
month, MonthOfYear
day) = Bool -> MonthOfYear -> (MonthOfYear, MonthOfYear)
dayOfYearToMonthAndDay (Year -> Bool
isJulianLeapYear Year
year) MonthOfYear
yd

-- | Convert from proleptic Julian calendar.
-- Invalid values will be clipped to the correct range, month first, then day.
fromJulian :: Year -> MonthOfYear -> DayOfMonth -> Day
fromJulian :: Year -> MonthOfYear -> MonthOfYear -> Day
fromJulian Year
year MonthOfYear
month MonthOfYear
day = Year -> MonthOfYear -> Day
fromJulianYearAndDay Year
year (Bool -> MonthOfYear -> MonthOfYear -> MonthOfYear
monthAndDayToDayOfYear (Year -> Bool
isJulianLeapYear Year
year) MonthOfYear
month MonthOfYear
day)

-- | Bidirectional abstract constructor for the proleptic Julian calendar.
-- Invalid values will be clipped to the correct range, month first, then day.
pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day
pattern $mJulianYearMonthDay :: forall {r}.
Day
-> (Year -> MonthOfYear -> MonthOfYear -> r) -> ((# #) -> r) -> r
$bJulianYearMonthDay :: Year -> MonthOfYear -> MonthOfYear -> Day
JulianYearMonthDay y m d <-
    (toJulian -> (y, m, d))
    where
        JulianYearMonthDay Year
y MonthOfYear
m MonthOfYear
d = Year -> MonthOfYear -> MonthOfYear -> Day
fromJulian Year
y MonthOfYear
m MonthOfYear
d

{-# COMPLETE JulianYearMonthDay #-}

-- | Convert from proleptic Julian calendar.
-- Invalid values will return Nothing.
fromJulianValid :: Year -> MonthOfYear -> DayOfMonth -> Maybe Day
fromJulianValid :: Year -> MonthOfYear -> MonthOfYear -> Maybe Day
fromJulianValid Year
year MonthOfYear
month MonthOfYear
day = do
    doy <- Bool -> MonthOfYear -> MonthOfYear -> Maybe MonthOfYear
monthAndDayToDayOfYearValid (Year -> Bool
isJulianLeapYear Year
year) MonthOfYear
month MonthOfYear
day
    fromJulianYearAndDayValid year doy

-- | Show in ISO 8601 format (yyyy-mm-dd)
showJulian :: Day -> String
showJulian :: Day -> String
showJulian Day
date = (Year -> String
forall t. ShowPadded t => t -> String
show4 Year
y) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (MonthOfYear -> String
forall t. ShowPadded t => t -> String
show2 MonthOfYear
m) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (MonthOfYear -> String
forall t. ShowPadded t => t -> String
show2 MonthOfYear
d)
  where
    (Year
y, MonthOfYear
m, MonthOfYear
d) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
date

-- | The number of days in a given month according to the proleptic Julian calendar.
julianMonthLength :: Year -> MonthOfYear -> DayOfMonth
julianMonthLength :: Year -> MonthOfYear -> MonthOfYear
julianMonthLength Year
year = Bool -> MonthOfYear -> MonthOfYear
monthLength (Year -> Bool
isJulianLeapYear Year
year)

rolloverMonths :: (Year, Integer) -> (Year, MonthOfYear)
rolloverMonths :: (Year, Year) -> (Year, MonthOfYear)
rolloverMonths (Year
y, Year
m) = (Year
y Year -> Year -> Year
forall a. Num a => a -> a -> a
+ (Year -> Year -> Year
forall a. Integral a => a -> a -> a
div (Year
m Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
1) Year
12), Year -> MonthOfYear
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Year -> Year -> Year
forall a. Integral a => a -> a -> a
mod (Year
m Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
1) Year
12) MonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
+ MonthOfYear
1)

addJulianMonths :: Integer -> Day -> (Year, MonthOfYear, DayOfMonth)
addJulianMonths :: Year -> Day -> (Year, MonthOfYear, MonthOfYear)
addJulianMonths Year
n Day
day = (Year
y', MonthOfYear
m', MonthOfYear
d)
  where
    (Year
y, MonthOfYear
m, MonthOfYear
d) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
day
    (Year
y', MonthOfYear
m') = (Year, Year) -> (Year, MonthOfYear)
rolloverMonths (Year
y, MonthOfYear -> Year
forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
m Year -> Year -> Year
forall a. Num a => a -> a -> a
+ Year
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.
addJulianMonthsClip :: Integer -> Day -> Day
addJulianMonthsClip :: Year -> Day -> Day
addJulianMonthsClip Year
n Day
day = Year -> MonthOfYear -> MonthOfYear -> Day
fromJulian Year
y MonthOfYear
m MonthOfYear
d
  where
    (Year
y, MonthOfYear
m, MonthOfYear
d) = Year -> Day -> (Year, MonthOfYear, MonthOfYear)
addJulianMonths Year
n Day
day

-- | Add months, with days past the last day of the month rolling over to the next month.
-- For instance, 2005-01-30 + 1 month = 2005-03-02.
addJulianMonthsRollOver :: Integer -> Day -> Day
addJulianMonthsRollOver :: Year -> Day -> Day
addJulianMonthsRollOver Year
n Day
day = Year -> Day -> Day
addDays (MonthOfYear -> Year
forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
d Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
1) (Year -> MonthOfYear -> MonthOfYear -> Day
fromJulian Year
y MonthOfYear
m MonthOfYear
1)
  where
    (Year
y, MonthOfYear
m, MonthOfYear
d) = Year -> Day -> (Year, MonthOfYear, MonthOfYear)
addJulianMonths Year
n Day
day

-- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary.
-- For instance, 2004-02-29 + 2 years = 2006-02-28.
addJulianYearsClip :: Integer -> Day -> Day
addJulianYearsClip :: Year -> Day -> Day
addJulianYearsClip Year
n = Year -> Day -> Day
addJulianMonthsClip (Year
n Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12)

-- | Add years, matching month and day, with Feb 29th rolled over to Mar 1st if necessary.
-- For instance, 2004-02-29 + 2 years = 2006-03-01.
addJulianYearsRollOver :: Integer -> Day -> Day
addJulianYearsRollOver :: Year -> Day -> Day
addJulianYearsRollOver Year
n = Year -> Day -> Day
addJulianMonthsRollOver (Year
n Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12)

-- | Add months (clipped to last day), then add days
addJulianDurationClip :: CalendarDiffDays -> Day -> Day
addJulianDurationClip :: CalendarDiffDays -> Day -> Day
addJulianDurationClip (CalendarDiffDays Year
m Year
d) Day
day = Year -> Day -> Day
addDays Year
d (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Year -> Day -> Day
addJulianMonthsClip Year
m Day
day

-- | Add months (rolling over to next month), then add days
addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day
addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day
addJulianDurationRollOver (CalendarDiffDays Year
m Year
d) Day
day = Year -> Day -> Day
addDays Year
d (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Year -> Day -> Day
addJulianMonthsRollOver Year
m Day
day

-- | Calendrical difference, with as many whole months as possible
diffJulianDurationClip :: Day -> Day -> CalendarDiffDays
diffJulianDurationClip :: Day -> Day -> CalendarDiffDays
diffJulianDurationClip Day
day2 Day
day1 =
    let
        (Year
y1, MonthOfYear
m1, MonthOfYear
d1) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
day1
        (Year
y2, MonthOfYear
m2, MonthOfYear
d2) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
day2
        ym1 :: Year
ym1 = Year
y1 Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ MonthOfYear -> Year
forall a. Integral a => a -> Year
toInteger MonthOfYear
m1
        ym2 :: Year
ym2 = Year
y2 Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ MonthOfYear -> Year
forall a. Integral a => a -> Year
toInteger MonthOfYear
m2
        ymdiff :: Year
ymdiff = Year
ym2 Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
ym1
        ymAllowed :: Year
ymAllowed =
            if Day
day2 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
day1
                then
                    if MonthOfYear
d2 MonthOfYear -> MonthOfYear -> Bool
forall a. Ord a => a -> a -> Bool
>= MonthOfYear
d1
                        then Year
ymdiff
                        else Year
ymdiff Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
1
                else
                    if MonthOfYear
d2 MonthOfYear -> MonthOfYear -> Bool
forall a. Ord a => a -> a -> Bool
<= MonthOfYear
d1
                        then Year
ymdiff
                        else Year
ymdiff Year -> Year -> Year
forall a. Num a => a -> a -> a
+ Year
1
        dayAllowed :: Day
dayAllowed = CalendarDiffDays -> Day -> Day
addJulianDurationClip (Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
ymAllowed Year
0) Day
day1
    in
        Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
ymAllowed (Year -> CalendarDiffDays) -> Year -> CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Year
diffDays Day
day2 Day
dayAllowed

-- | Calendrical difference, with as many whole months as possible.
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver Day
day2 Day
day1 =
    let
        (Year
y1, MonthOfYear
m1, MonthOfYear
_) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
day1
        (Year
y2, MonthOfYear
m2, MonthOfYear
_) = Day -> (Year, MonthOfYear, MonthOfYear)
toJulian Day
day2
        ym1 :: Year
ym1 = Year
y1 Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ MonthOfYear -> Year
forall a. Integral a => a -> Year
toInteger MonthOfYear
m1
        ym2 :: Year
ym2 = Year
y2 Year -> Year -> Year
forall a. Num a => a -> a -> a
* Year
12 Year -> Year -> Year
forall a. Num a => a -> a -> a
+ MonthOfYear -> Year
forall a. Integral a => a -> Year
toInteger MonthOfYear
m2
        ymdiff :: Year
ymdiff = Year
ym2 Year -> Year -> Year
forall a. Num a => a -> a -> a
- Year
ym1
        findpos :: Year -> CalendarDiffDays
findpos Year
mdiff =
            let
                dayAllowed :: Day
dayAllowed = CalendarDiffDays -> Day -> Day
addJulianDurationRollOver (Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
mdiff Year
0) Day
day1
                dd :: Year
dd = Day -> Day -> Year
diffDays Day
day2 Day
dayAllowed
            in
                if Year
dd Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
>= Year
0 then Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
mdiff Year
dd else Year -> CalendarDiffDays
findpos (Year -> Year
forall a. Enum a => a -> a
pred Year
mdiff)
        findneg :: Year -> CalendarDiffDays
findneg Year
mdiff =
            let
                dayAllowed :: Day
dayAllowed = CalendarDiffDays -> Day -> Day
addJulianDurationRollOver (Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
mdiff Year
0) Day
day1
                dd :: Year
dd = Day -> Day -> Year
diffDays Day
day2 Day
dayAllowed
            in
                if Year
dd Year -> Year -> Bool
forall a. Ord a => a -> a -> Bool
<= Year
0 then Year -> Year -> CalendarDiffDays
CalendarDiffDays Year
mdiff Year
dd else Year -> CalendarDiffDays
findpos (Year -> Year
forall a. Enum a => a -> a
succ Year
mdiff)
    in
        if Day
day2 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
day1
            then Year -> CalendarDiffDays
findpos Year
ymdiff
            else Year -> CalendarDiffDays
findneg Year
ymdiff