{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.Time.Calendar.Compat (
Day(..),addDays,diffDays,
DayPeriod (..),
periodAllDays,
periodLength,
periodFromDay,
periodToDay,
periodToDayValid,
CalendarDiffDays (..),
calendarDay,calendarWeek,calendarMonth,calendarYear,scaleCalendarDiffDays,
Year,
pattern CommonEra,
pattern BeforeCommonEra,
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,
toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength,
addGregorianMonthsClip,addGregorianMonthsRollOver,
addGregorianYearsClip,addGregorianYearsRollOver,
addGregorianDurationClip,addGregorianDurationRollOver,
diffGregorianDurationClip,diffGregorianDurationRollOver,
isLeapYear ,
DayOfWeek(..), dayOfWeek,
dayOfWeekDiff, firstDayOfWeekOnAfter,
weekAllDays,
weekFirstDay,
weekLastDay,
pattern YearMonthDay,
) where
#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_time(1,14,0)
import Data.Time.Calendar hiding (diffGregorianDurationRollOver)
#else
import Data.Time.Calendar
#endif
import Data.Time.Format
import Data.Time.Orphans ()
#if !MIN_VERSION_time(1,12,1)
import Data.Time.Calendar.Types
#endif
#if !MIN_VERSION_time(1,9,0)
import Data.Time.Calendar.WeekDate.Compat
#endif
#if !MIN_VERSION_time(1,12,0)
import Data.Time.Calendar.MonthDay.Compat
#endif
#if !MIN_VERSION_time(1,12,0)
import Data.Time.Calendar.Types
#endif
#if !MIN_VERSION_time(1,12,1)
import Data.Time.Calendar.Month.Compat
import Data.Time.Calendar.Quarter.Compat
#endif
import Control.DeepSeq (NFData (..))
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Data.Monoid (Monoid (..))
import Data.Semigroup (Semigroup (..))
import qualified Language.Haskell.TH.Syntax as TH
#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_time(1,9,2)
deriving instance Typeable CalendarDiffDays
deriving instance Data CalendarDiffDays
#endif
#if !MIN_VERSION_time(1,9,0)
data CalendarDiffDays = CalendarDiffDays
{ cdMonths :: Integer
, cdDays :: Integer
} deriving (Eq, Data, Typeable, Generic, TH.Lift)
instance Semigroup CalendarDiffDays where
CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2)
instance Monoid CalendarDiffDays where
mempty = CalendarDiffDays 0 0
mappend = (<>)
instance Show CalendarDiffDays where
show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D"
instance NFData CalendarDiffDays where
rnf (CalendarDiffDays x y) = rnf x `seq` rnf y
calendarDay :: CalendarDiffDays
calendarDay = CalendarDiffDays 0 1
calendarWeek :: CalendarDiffDays
calendarWeek = CalendarDiffDays 0 7
calendarMonth :: CalendarDiffDays
calendarMonth = CalendarDiffDays 1 0
calendarYear :: CalendarDiffDays
calendarYear = CalendarDiffDays 12 0
scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays
scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d)
#endif
#if !MIN_VERSION_time(1,9,0)
addGregorianDurationClip :: CalendarDiffDays -> Day -> Day
addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day
addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day
addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day
diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
diffGregorianDurationClip day2 day1 = let
(y1,m1,d1) = toGregorian day1
(y2,m2,d2) = toGregorian 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 = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
#endif
#if !MIN_VERSION_time(1,14,0)
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver Day
day2 Day
day1 =
let
(Year
y1, MonthOfYear
m1, MonthOfYear
_) = Day -> (Year, MonthOfYear, MonthOfYear)
toGregorian Day
day1
(Year
y2, MonthOfYear
m2, MonthOfYear
_) = Day -> (Year, MonthOfYear, MonthOfYear)
toGregorian 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
addGregorianDurationRollOver (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
addGregorianDurationRollOver (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
#endif
#if !MIN_VERSION_time(1,11,0)
pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day
pattern YearMonthDay y m d <- (toGregorian -> (y,m,d)) where
YearMonthDay y m d = fromGregorian y m d
{-# COMPLETE YearMonthDay #-}
#endif
#if !MIN_VERSION_time(1,11,0)
dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
#endif
#if !MIN_VERSION_time(1,12,2)
weekAllDays :: DayOfWeek -> Day -> [Day]
weekAllDays firstDay day = [weekFirstDay firstDay day .. weekLastDay firstDay day]
weekFirstDay :: DayOfWeek -> Day -> Day
weekFirstDay firstDay day = addDays (negate 7) $ firstDayOfWeekOnAfter firstDay $ succ day
weekLastDay :: DayOfWeek -> Day -> Day
weekLastDay firstDay day = pred $ firstDayOfWeekOnAfter firstDay $ succ day
#endif
#if !MIN_VERSION_time(1,12,1)
class Ord p => DayPeriod p where
periodFirstDay :: p -> Day
periodLastDay :: p -> Day
dayPeriod :: Day -> p
periodAllDays :: DayPeriod p => p -> [Day]
periodAllDays p = [periodFirstDay p .. periodLastDay p]
periodLength :: DayPeriod p => p -> Int
periodLength p = succ $ fromInteger $ diffDays (periodLastDay p) (periodFirstDay p)
periodFromDay :: DayPeriod p => Day -> (p, Int)
periodFromDay d =
let
p = dayPeriod d
dt = succ $ fromInteger $ diffDays d $ periodFirstDay p
in
(p, dt)
periodToDay :: DayPeriod p => p -> Int -> Day
periodToDay p i = addDays (toInteger $ pred i) $ periodFirstDay p
periodToDayValid :: DayPeriod p => p -> Int -> Maybe Day
periodToDayValid p i =
let
d = periodToDay p i
in
if fst (periodFromDay d) == p then Just d else Nothing
instance DayPeriod Day where
periodFirstDay = id
periodLastDay = id
dayPeriod = id
instance DayPeriod Year where
periodFirstDay y = YearMonthDay y January 1
periodLastDay y = YearMonthDay y December 31
dayPeriod (YearMonthDay y _ _) = y
instance DayPeriod Month where
periodFirstDay (YearMonth y m) = YearMonthDay y m 1
periodLastDay (YearMonth y m) = YearMonthDay y m 31
dayPeriod (YearMonthDay y my _) = YearMonth y my
instance DayPeriod Quarter where
periodFirstDay (YearQuarter y q) =
case q of
Q1 -> periodFirstDay $ YearMonth y January
Q2 -> periodFirstDay $ YearMonth y April
Q3 -> periodFirstDay $ YearMonth y July
Q4 -> periodFirstDay $ YearMonth y October
periodLastDay (YearQuarter y q) =
case q of
Q1 -> periodLastDay $ YearMonth y March
Q2 -> periodLastDay $ YearMonth y June
Q3 -> periodLastDay $ YearMonth y September
Q4 -> periodLastDay $ YearMonth y December
dayPeriod (MonthDay m _) = monthQuarter m
#endif