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