1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3#if __GLASGOW_HASKELL__ >= 710 4{-# LANGUAGE PatternSynonyms #-} 5{-# LANGUAGE ViewPatterns #-} 6#endif 7module Data.Time.Calendar.Compat ( 8 -- * Days 9 Day(..),addDays,diffDays, 10 11 -- * CalendarDiffTime 12 CalendarDiffDays (..), 13 calendarDay,calendarWeek,calendarMonth,calendarYear,scaleCalendarDiffDays, 14 15 -- * Gregorian calendar 16 toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength, 17 18 -- calendrical arithmetic 19 -- e.g. "one month after March 31st" 20 addGregorianMonthsClip,addGregorianMonthsRollOver, 21 addGregorianYearsClip,addGregorianYearsRollOver, 22 addGregorianDurationClip,addGregorianDurationRollOver, 23 diffGregorianDurationClip,diffGregorianDurationRollOver, 24 25 -- re-exported from OrdinalDate 26 isLeapYear , 27 28 -- * Week 29 DayOfWeek(..), dayOfWeek, 30 dayOfWeekDiff, firstDayOfWeekOnAfter, 31 32 -- * Type aliases 33 DayOfMonth, MonthOfYear, Year, 34#if __GLASGOW_HASKELL__ >= 710 35 pattern YearMonthDay, 36#endif 37 ) where 38 39import Data.Time.Calendar 40import Data.Time.Format 41import Data.Time.Orphans () 42 43#if !MIN_VERSION_time(1,11,0) 44import Data.Time.Calendar.Types 45#endif 46 47#if !MIN_VERSION_time(1,9,0) 48import Data.Time.Calendar.WeekDate.Compat 49#endif 50 51#if !MIN_VERSION_time(1,5,0) 52import System.Locale (TimeLocale (..)) 53#endif 54 55import Control.DeepSeq (NFData (..)) 56import Data.Data (Data, Typeable) 57import Data.Monoid (Monoid (..)) 58import Data.Semigroup (Semigroup (..)) 59 60------------------------------------------------------------------------------- 61-- CalendarDiffTime 62------------------------------------------------------------------------------- 63 64#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_time(1,9,2) 65deriving instance Typeable CalendarDiffDays 66deriving instance Data CalendarDiffDays 67#endif 68 69#if !MIN_VERSION_time(1,9,0) 70 71data CalendarDiffDays = CalendarDiffDays 72 { cdMonths :: Integer 73 , cdDays :: Integer 74 } deriving (Eq, 75 Data 76#if __GLASGOW_HASKELL__ >= 802 77#endif 78 ,Typeable 79#if __GLASGOW_HASKELL__ >= 802 80#endif 81 ) 82 83-- | Additive 84instance Semigroup CalendarDiffDays where 85 CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2) 86 87-- | Additive 88instance Monoid CalendarDiffDays where 89 mempty = CalendarDiffDays 0 0 90 mappend = (<>) 91 92instance Show CalendarDiffDays where 93 show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D" 94 95instance NFData CalendarDiffDays where 96 rnf (CalendarDiffDays x y) = rnf x `seq` rnf y 97 98calendarDay :: CalendarDiffDays 99calendarDay = CalendarDiffDays 0 1 100 101calendarWeek :: CalendarDiffDays 102calendarWeek = CalendarDiffDays 0 7 103 104calendarMonth :: CalendarDiffDays 105calendarMonth = CalendarDiffDays 1 0 106 107calendarYear :: CalendarDiffDays 108calendarYear = CalendarDiffDays 12 0 109 110-- | Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths. 111scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays 112scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d) 113 114#endif 115 116------------------------------------------------------------------------------- 117-- Gregorian 118------------------------------------------------------------------------------- 119 120#if !MIN_VERSION_time(1,9,0) 121 122-- | Add months (clipped to last day), then add days 123addGregorianDurationClip :: CalendarDiffDays -> Day -> Day 124addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day 125 126-- | Add months (rolling over to next month), then add days 127addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day 128addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day 129 130-- | Calendrical difference, with as many whole months as possible 131diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays 132diffGregorianDurationClip day2 day1 = let 133 (y1,m1,d1) = toGregorian day1 134 (y2,m2,d2) = toGregorian day2 135 ym1 = y1 * 12 + toInteger m1 136 ym2 = y2 * 12 + toInteger m2 137 ymdiff = ym2 - ym1 138 ymAllowed = 139 if day2 >= day1 then 140 if d2 >= d1 then ymdiff else ymdiff - 1 141 else if d2 <= d1 then ymdiff else ymdiff + 1 142 dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 143 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 144 145-- | Calendrical difference, with as many whole months as possible. 146-- Same as 'diffGregorianDurationClip' for positive durations. 147diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays 148diffGregorianDurationRollOver day2 day1 = let 149 (y1,m1,d1) = toGregorian day1 150 (y2,m2,d2) = toGregorian day2 151 ym1 = y1 * 12 + toInteger m1 152 ym2 = y2 * 12 + toInteger m2 153 ymdiff = ym2 - ym1 154 ymAllowed = 155 if day2 >= day1 then 156 if d2 >= d1 then ymdiff else ymdiff - 1 157 else if d2 <= d1 then ymdiff else ymdiff + 1 158 dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 159 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 160 161#endif 162 163#if !MIN_VERSION_time(1,11,0) 164#if __GLASGOW_HASKELL__ >= 710 165-- | Bidirectional abstract constructor for the proleptic Gregorian calendar. 166-- Invalid values will be clipped to the correct range, month first, then day. 167pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day 168pattern YearMonthDay y m d <- (toGregorian -> (y,m,d)) where 169 YearMonthDay y m d = fromGregorian y m d 170 171#if __GLASGOW_HASKELL__ >= 802 172{-# COMPLETE YearMonthDay #-} 173#endif 174#endif 175#endif 176 177------------------------------------------------------------------------------- 178-- DayOfWeek 179------------------------------------------------------------------------------- 180 181#if !MIN_VERSION_time(1,11,0) 182-- | @dayOfWeekDiff a b = a - b@ in range 0 to 6. 183-- The number of days from b to the next a. 184dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int 185dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7 186 187-- | The first day-of-week on or after some day 188firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day 189firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d 190#endif 191