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