{-# LANGUAGE Safe #-}

module Data.Time.Calendar.Julian
    ( Year
    , MonthOfYear
    , DayOfMonth
    , DayOfYear
    , 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.Types
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

-- | 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

#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE JulianYearMonthDay #-}
#endif

-- | 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
    MonthOfYear
doy <- Bool -> MonthOfYear -> MonthOfYear -> Maybe MonthOfYear
monthAndDayToDayOfYearValid (Year -> Bool
isJulianLeapYear Year
year) MonthOfYear
month MonthOfYear
day
    Year -> MonthOfYear -> Maybe Day
fromJulianYearAndDayValid Year
year MonthOfYear
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.
-- Same as 'diffJulianDurationClip' for positive durations.
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver 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
addJulianDurationRollOver (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