{-# 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,
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 :: 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
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)
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 #-}
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
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
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)
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
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
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)
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)
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
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
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
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