1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3module Data.Time.Calendar.Compat ( 4 -- * Days 5 Day(..),addDays,diffDays, 6 7 -- * CalendarDiffTime 8 CalendarDiffDays (..), 9 calendarDay,calendarWeek,calendarMonth,calendarYear,scaleCalendarDiffDays, 10 11 -- * Gregorian calendar 12 toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength, 13 14 -- calendrical arithmetic 15 -- e.g. "one month after March 31st" 16 addGregorianMonthsClip,addGregorianMonthsRollOver, 17 addGregorianYearsClip,addGregorianYearsRollOver, 18 addGregorianDurationClip,addGregorianDurationRollOver, 19 diffGregorianDurationClip,diffGregorianDurationRollOver, 20 21 -- re-exported from OrdinalDate 22 isLeapYear , 23 24 -- * Week 25 DayOfWeek(..), dayOfWeek, 26 ) where 27 28import Data.Time.Calendar 29import Data.Time.Format 30import Data.Time.Orphans () 31 32#if !MIN_VERSION_time(1,5,0) 33import System.Locale (TimeLocale (..)) 34#endif 35 36import Data.Data (Data, Typeable) 37import Data.Monoid (Monoid (..)) 38import Data.Semigroup (Semigroup (..)) 39 40 41------------------------------------------------------------------------------- 42-- CalendarDiffTime 43------------------------------------------------------------------------------- 44 45#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_base(1,9,2) 46deriving instance Typeable CalendarDiffDays 47deriving instance Data CalendarDiffDays 48#endif 49 50#if !MIN_VERSION_time(1,9,0) 51 52data CalendarDiffDays = CalendarDiffDays 53 { cdMonths :: Integer 54 , cdDays :: Integer 55 } deriving (Eq, 56 Data 57#if __GLASGOW_HASKELL__ >= 802 58#endif 59 ,Typeable 60#if __GLASGOW_HASKELL__ >= 802 61#endif 62 ) 63 64-- | Additive 65instance Semigroup CalendarDiffDays where 66 CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2) 67 68-- | Additive 69instance Monoid CalendarDiffDays where 70 mempty = CalendarDiffDays 0 0 71 mappend = (<>) 72 73instance Show CalendarDiffDays where 74 show (CalendarDiffDays m d) = "P" ++ show m ++ "M" ++ show d ++ "D" 75 76calendarDay :: CalendarDiffDays 77calendarDay = CalendarDiffDays 0 1 78 79calendarWeek :: CalendarDiffDays 80calendarWeek = CalendarDiffDays 0 7 81 82calendarMonth :: CalendarDiffDays 83calendarMonth = CalendarDiffDays 1 0 84 85calendarYear :: CalendarDiffDays 86calendarYear = CalendarDiffDays 12 0 87 88-- | Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths. 89scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays 90scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d) 91 92#endif 93 94------------------------------------------------------------------------------- 95-- Gregorian 96------------------------------------------------------------------------------- 97 98#if !MIN_VERSION_time(1,9,0) 99 100-- | Add months (clipped to last day), then add days 101addGregorianDurationClip :: CalendarDiffDays -> Day -> Day 102addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day 103 104-- | Add months (rolling over to next month), then add days 105addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day 106addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day 107 108-- | Calendrical difference, with as many whole months as possible 109diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays 110diffGregorianDurationClip day2 day1 = let 111 (y1,m1,d1) = toGregorian day1 112 (y2,m2,d2) = toGregorian day2 113 ym1 = y1 * 12 + toInteger m1 114 ym2 = y2 * 12 + toInteger m2 115 ymdiff = ym2 - ym1 116 ymAllowed = 117 if day2 >= day1 then 118 if d2 >= d1 then ymdiff else ymdiff - 1 119 else if d2 <= d1 then ymdiff else ymdiff + 1 120 dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 121 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 122 123-- | Calendrical difference, with as many whole months as possible. 124-- Same as 'diffGregorianDurationClip' for positive durations. 125diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays 126diffGregorianDurationRollOver day2 day1 = let 127 (y1,m1,d1) = toGregorian day1 128 (y2,m2,d2) = toGregorian day2 129 ym1 = y1 * 12 + toInteger m1 130 ym2 = y2 * 12 + toInteger m2 131 ymdiff = ym2 - ym1 132 ymAllowed = 133 if day2 >= day1 then 134 if d2 >= d1 then ymdiff else ymdiff - 1 135 else if d2 <= d1 then ymdiff else ymdiff + 1 136 dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 137 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 138 139#endif 140 141------------------------------------------------------------------------------- 142-- DayOfWeek 143------------------------------------------------------------------------------- 144 145#if !MIN_VERSION_time(1,9,0) 146 147data DayOfWeek 148 = Monday 149 | Tuesday 150 | Wednesday 151 | Thursday 152 | Friday 153 | Saturday 154 | Sunday 155 deriving (Eq, Show, Read, Typeable) 156 157-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. 158-- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. 159instance Enum DayOfWeek where 160 toEnum i = 161 case mod i 7 of 162 0 -> Sunday 163 1 -> Monday 164 2 -> Tuesday 165 3 -> Wednesday 166 4 -> Thursday 167 5 -> Friday 168 _ -> Saturday 169 fromEnum Monday = 1 170 fromEnum Tuesday = 2 171 fromEnum Wednesday = 3 172 fromEnum Thursday = 4 173 fromEnum Friday = 5 174 fromEnum Saturday = 6 175 fromEnum Sunday = 7 176 enumFromTo wd1 wd2 177 | wd1 == wd2 = [wd1] 178 enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2 179 enumFromThenTo wd1 wd2 wd3 180 | wd2 == wd3 = [wd1, wd2] 181 enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3 182 183dayOfWeek :: Day -> DayOfWeek 184dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 185 186toSomeDay :: DayOfWeek -> Day 187toSomeDay d = ModifiedJulianDay (fromIntegral $ fromEnum d + 4) 188 189#if MIN_VERSION_time(1,8,0) 190#define FORMAT_OPTS tl mpo i 191#else 192#define FORMAT_OPTS tl mpo 193#endif 194 195instance FormatTime DayOfWeek where 196 formatCharacter 'u' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'u') 197 formatCharacter 'w' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'w') 198 formatCharacter 'a' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'a') 199 formatCharacter 'A' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'A') 200 formatCharacter _ = Nothing 201 202#endif 203