{-# OPTIONS -fno-warn-orphans #-}
module Data.Time.Calendar.Gregorian
(
toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength,
addGregorianMonthsClip,addGregorianMonthsRollOver,
addGregorianYearsClip,addGregorianYearsRollOver,
addGregorianDurationClip,addGregorianDurationRollOver,
diffGregorianDurationClip,diffGregorianDurationRollOver,
isLeapYear
) where
import Data.Time.Calendar.MonthDay
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Days
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.Private
toGregorian :: Day -> (Integer,Int,Int)
toGregorian :: Day -> (Integer, Int, Int)
toGregorian date :: Day
date = (Integer
year,Int
month,Int
day) where
(year :: Integer
year,yd :: Int
yd) = Day -> (Integer, Int)
toOrdinalDate Day
date
(month :: Int
month,day :: Int
day) = Bool -> Int -> (Int, Int)
dayOfYearToMonthAndDay (Integer -> Bool
isLeapYear Integer
year) Int
yd
fromGregorian :: Integer -> Int -> Int -> Day
fromGregorian :: Integer -> Int -> Int -> Day
fromGregorian year :: Integer
year month :: Int
month day :: Int
day = Integer -> Int -> Day
fromOrdinalDate Integer
year (Bool -> Int -> Int -> Int
monthAndDayToDayOfYear (Integer -> Bool
isLeapYear Integer
year) Int
month Int
day)
fromGregorianValid :: Integer -> Int -> Int -> Maybe Day
fromGregorianValid :: Integer -> Int -> Int -> Maybe Day
fromGregorianValid year :: Integer
year month :: Int
month day :: Int
day = do
Int
doy <- Bool -> Int -> Int -> Maybe Int
monthAndDayToDayOfYearValid (Integer -> Bool
isLeapYear Integer
year) Int
month Int
day
Integer -> Int -> Maybe Day
fromOrdinalDateValid Integer
year Int
doy
showGregorian :: Day -> String
showGregorian :: Day -> String
showGregorian date :: Day
date = (Integer -> String
forall t. ShowPadded t => t -> String
show4 Integer
y) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall t. ShowPadded t => t -> String
show2 Int
m) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall t. ShowPadded t => t -> String
show2 Int
d) where
(y :: Integer
y,m :: Int
m,d :: Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
date
gregorianMonthLength :: Integer -> Int -> Int
gregorianMonthLength :: Integer -> Int -> Int
gregorianMonthLength year :: Integer
year = Bool -> Int -> Int
monthLength (Integer -> Bool
isLeapYear Integer
year)
rolloverMonths :: (Integer,Integer) -> (Integer,Int)
rolloverMonths :: (Integer, Integer) -> (Integer, Int)
rolloverMonths (y :: Integer
y,m :: Integer
m) = (Integer
y Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div (Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1) 12),Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod (Integer
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1) 12) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
addGregorianMonths :: Integer -> Day -> (Integer,Int,Int)
addGregorianMonths :: Integer -> Day -> (Integer, Int, Int)
addGregorianMonths n :: Integer
n day :: Day
day = (Integer
y',Int
m',Int
d) where
(y :: Integer
y,m :: Int
m,d :: Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
(y' :: Integer
y',m' :: Int
m') = (Integer, Integer) -> (Integer, Int)
rolloverMonths (Integer
y,Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n)
addGregorianMonthsClip :: Integer -> Day -> Day
addGregorianMonthsClip :: Integer -> Day -> Day
addGregorianMonthsClip n :: Integer
n day :: Day
day = Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m Int
d where
(y :: Integer
y,m :: Int
m,d :: Int
d) = Integer -> Day -> (Integer, Int, Int)
addGregorianMonths Integer
n Day
day
addGregorianMonthsRollOver :: Integer -> Day -> Day
addGregorianMonthsRollOver :: Integer -> Day -> Day
addGregorianMonthsRollOver n :: Integer
n day :: Day
day = Integer -> Day -> Day
addDays (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1) (Integer -> Int -> Int -> Day
fromGregorian Integer
y Int
m 1) where
(y :: Integer
y,m :: Int
m,d :: Int
d) = Integer -> Day -> (Integer, Int, Int)
addGregorianMonths Integer
n Day
day
addGregorianYearsClip :: Integer -> Day -> Day
addGregorianYearsClip :: Integer -> Day -> Day
addGregorianYearsClip n :: Integer
n = Integer -> Day -> Day
addGregorianMonthsClip (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12)
addGregorianYearsRollOver :: Integer -> Day -> Day
addGregorianYearsRollOver :: Integer -> Day -> Day
addGregorianYearsRollOver n :: Integer
n = Integer -> Day -> Day
addGregorianMonthsRollOver (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12)
addGregorianDurationClip :: CalendarDiffDays -> Day -> Day
addGregorianDurationClip :: CalendarDiffDays -> Day -> Day
addGregorianDurationClip (CalendarDiffDays m :: Integer
m d :: Integer
d) day :: Day
day = Integer -> Day -> Day
addDays Integer
d (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsClip Integer
m Day
day
addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver (CalendarDiffDays m :: Integer
m d :: Integer
d) day :: Day
day = Integer -> Day -> Day
addDays Integer
d (Day -> Day) -> Day -> Day
forall a b. (a -> b) -> a -> b
$ Integer -> Day -> Day
addGregorianMonthsRollOver Integer
m Day
day
diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
diffGregorianDurationClip day2 :: Day
day2 day1 :: Day
day1 = let
(y1 :: Integer
y1,m1 :: Int
m1,d1 :: Int
d1) = Day -> (Integer, Int, Int)
toGregorian Day
day1
(y2 :: Integer
y2,m2 :: Int
m2,d2 :: Int
d2) = Day -> (Integer, Int, Int)
toGregorian Day
day2
ym1 :: Integer
ym1 = Integer
y1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m1
ym2 :: Integer
ym2 = Integer
y2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m2
ymdiff :: Integer
ymdiff = Integer
ym2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
ym1
ymAllowed :: Integer
ymAllowed =
if Day
day2 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
day1 then
if Int
d2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d1 then Integer
ymdiff else Integer
ymdiff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1
else if Int
d2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d1 then Integer
ymdiff else Integer
ymdiff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1
dayAllowed :: Day
dayAllowed = CalendarDiffDays -> Day -> Day
addGregorianDurationClip (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
ymAllowed 0) Day
day1
in Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
ymAllowed (Integer -> CalendarDiffDays) -> Integer -> CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays Day
day2 Day
dayAllowed
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver day2 :: Day
day2 day1 :: Day
day1 = let
(y1 :: Integer
y1,m1 :: Int
m1,d1 :: Int
d1) = Day -> (Integer, Int, Int)
toGregorian Day
day1
(y2 :: Integer
y2,m2 :: Int
m2,d2 :: Int
d2) = Day -> (Integer, Int, Int)
toGregorian Day
day2
ym1 :: Integer
ym1 = Integer
y1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m1
ym2 :: Integer
ym2 = Integer
y2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m2
ymdiff :: Integer
ymdiff = Integer
ym2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
ym1
ymAllowed :: Integer
ymAllowed =
if Day
day2 Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day
day1 then
if Int
d2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
d1 then Integer
ymdiff else Integer
ymdiff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1
else if Int
d2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
d1 then Integer
ymdiff else Integer
ymdiff Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1
dayAllowed :: Day
dayAllowed = CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
ymAllowed 0) Day
day1
in Integer -> Integer -> CalendarDiffDays
CalendarDiffDays Integer
ymAllowed (Integer -> CalendarDiffDays) -> Integer -> CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ Day -> Day -> Integer
diffDays Day
day2 Day
dayAllowed
instance Show Day where
show :: Day -> String
show = Day -> String
showGregorian