1{-# LANGUAGE CPP #-} 2{-# LANGUAGE BangPatterns #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4#if __GLASGOW_HASKELL__ >= 710 5{-# LANGUAGE PatternSynonyms #-} 6{-# LANGUAGE ViewPatterns #-} 7#endif 8module Data.Time.Calendar.WeekDate.Compat ( 9 Year, WeekOfYear, DayOfWeek(..), dayOfWeek, 10 FirstWeekType (..), 11 toWeekCalendar, 12 fromWeekCalendar, 13 fromWeekCalendarValid, 14 15 16 -- * ISO 8601 Week Date format 17 toWeekDate, 18 fromWeekDate, 19#if __GLASGOW_HASKELL__ >= 710 20 pattern YearWeekDay, 21#endif 22 fromWeekDateValid, 23 showWeekDate, 24) where 25 26import Data.Time.Orphans () 27 28import Data.Time.Calendar 29import Data.Time.Calendar.WeekDate 30 31#if !MIN_VERSION_time(1,9,0) 32import Data.Time.Format 33#endif 34 35#if !MIN_VERSION_time(1,11,0) 36import Data.Data (Data) 37import Data.Typeable (Typeable) 38import Data.Time.Calendar.Types 39import Data.Time.Calendar.Private 40import Data.Time.Calendar.OrdinalDate 41#endif 42 43import Control.DeepSeq (NFData (..)) 44 45 46#if !MIN_VERSION_time(1,11,0) 47data FirstWeekType 48 = FirstWholeWeek 49 -- ^ first week is the first whole week of the year 50 | FirstMostWeek 51 -- ^ first week is the first week with four days in the year 52 deriving (Eq, Typeable) 53 54firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day 55firstDayOfWeekCalendar wt dow year = let 56 jan1st = fromOrdinalDate year 1 57 in case wt of 58 FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st 59 FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st 60 61-- Note that the year number matches the weeks, and so is not always the same as the Gregorian year number. 62toWeekCalendar :: 63 FirstWeekType 64 -- ^ how to reckon the first week of the year 65 -> DayOfWeek 66 -- ^ the first day of each week 67 -> Day 68 -> (Year, WeekOfYear, DayOfWeek) 69toWeekCalendar wt ws d = let 70 dw = dayOfWeek d 71 (y0,_) = toOrdinalDate d 72 j1p = firstDayOfWeekCalendar wt ws $ pred y0 73 j1 = firstDayOfWeekCalendar wt ws y0 74 j1s = firstDayOfWeekCalendar wt ws $ succ y0 75 in if d < j1 76 then (pred y0,succ $ div (fromInteger $ diffDays d j1p) 7,dw) 77 else if d < j1s then (y0,succ $ div (fromInteger $ diffDays d j1) 7,dw) 78 else (succ y0,succ $ div (fromInteger $ diffDays d j1s) 7,dw) 79 80-- | Convert from the given kind of "week calendar". 81-- Invalid week and day values will be clipped to the correct range. 82fromWeekCalendar :: 83 FirstWeekType 84 -- ^ how to reckon the first week of the year 85 -> DayOfWeek 86 -- ^ the first day of each week 87 -> Year -> WeekOfYear -> DayOfWeek -> Day 88fromWeekCalendar wt ws y wy dw = let 89 d1 :: Day 90 d1 = firstDayOfWeekCalendar wt ws y 91 wy' = clip 1 53 wy 92 getday :: WeekOfYear -> Day 93 getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1 94 d1s = firstDayOfWeekCalendar wt ws $ succ y 95 day = getday wy' 96 in if wy' == 53 then if day >= d1s then getday 52 else day else day 97 98-- | Convert from the given kind of "week calendar". 99-- Invalid week and day values will return Nothing. 100fromWeekCalendarValid :: 101 FirstWeekType 102 -- ^ how to reckon the first week of the year 103 -> DayOfWeek 104 -- ^ the first day of each week 105 -> Year -> WeekOfYear -> DayOfWeek -> Maybe Day 106fromWeekCalendarValid wt ws y wy dw = let 107 d = fromWeekCalendar wt ws y wy dw 108 in if toWeekCalendar wt ws d == (y,wy,dw) then Just d else Nothing 109 110#if __GLASGOW_HASKELL__ >= 710 111-- | Bidirectional abstract constructor for ISO 8601 Week Date format. 112-- Invalid week values will be clipped to the correct range. 113pattern YearWeekDay :: Year -> WeekOfYear -> DayOfWeek -> Day 114pattern YearWeekDay y wy dw <- (toWeekDate -> (y,wy,toEnum -> dw)) where 115 YearWeekDay y wy dw = fromWeekDate y wy (fromEnum dw) 116 117#if __GLASGOW_HASKELL__ >= 802 118{-# COMPLETE YearWeekDay #-} 119#endif 120#endif 121 122#endif 123 124#if !MIN_VERSION_time(1,9,0) 125 126data DayOfWeek 127 = Monday 128 | Tuesday 129 | Wednesday 130 | Thursday 131 | Friday 132 | Saturday 133 | Sunday 134 deriving (Eq, Ord, Show, Read, Typeable, Data) 135 136instance NFData DayOfWeek where 137 rnf !_ = () 138 139-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. 140-- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. 141instance Enum DayOfWeek where 142 toEnum i = 143 case mod i 7 of 144 0 -> Sunday 145 1 -> Monday 146 2 -> Tuesday 147 3 -> Wednesday 148 4 -> Thursday 149 5 -> Friday 150 _ -> Saturday 151 fromEnum Monday = 1 152 fromEnum Tuesday = 2 153 fromEnum Wednesday = 3 154 fromEnum Thursday = 4 155 fromEnum Friday = 5 156 fromEnum Saturday = 6 157 fromEnum Sunday = 7 158 enumFromTo wd1 wd2 159 | wd1 == wd2 = [wd1] 160 enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2 161 enumFromThenTo wd1 wd2 wd3 162 | wd2 == wd3 = [wd1, wd2] 163 enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3 164 165dayOfWeek :: Day -> DayOfWeek 166dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 167 168 169 170------------------------------------------------------------------------------- 171-- FormatTime DayOfWeek 172------------------------------------------------------------------------------- 173 174toSomeDay :: DayOfWeek -> Day 175toSomeDay d = ModifiedJulianDay (fromIntegral $ fromEnum d + 4) 176 177#if MIN_VERSION_time(1,8,0) 178#define FORMAT_OPTS tl mpo i 179#else 180#define FORMAT_OPTS tl mpo 181#endif 182 183instance FormatTime DayOfWeek where 184 formatCharacter 'u' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'u') 185 formatCharacter 'w' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'w') 186 formatCharacter 'a' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'a') 187 formatCharacter 'A' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter 'A') 188 formatCharacter _ = Nothing 189 190#endif 191 192#if !MIN_VERSION_time(1,11,0) 193-- | @dayOfWeekDiff a b = a - b@ in range 0 to 6. 194-- The number of days from b to the next a. 195dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int 196dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7 197 198-- | The first day-of-week on or after some day 199firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day 200firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d 201#endif 202