1{-# LANGUAGE CPP                #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3#if __GLASGOW_HASKELL__ >= 710
4{-# LANGUAGE PatternSynonyms    #-}
5{-# LANGUAGE ViewPatterns       #-}
6#endif
7module Data.Time.Calendar.Month.Compat (
8    Month(..), addMonths, diffMonths,
9#if __GLASGOW_HASKELL__ >= 710
10    pattern YearMonth,
11#endif
12    fromYearMonthValid,
13#if __GLASGOW_HASKELL__ >= 710
14    pattern MonthDay,
15#endif
16    fromMonthDayValid,
17    -- * time-compat extras
18    fromYearMonth,
19    toYearMonth,
20    fromMonthDay,
21    toMonthDay,
22) where
23
24#if MIN_VERSION_time(1,11,0)
25import Data.Time.Calendar
26import Data.Time.Calendar.Month
27
28-- | Part of @YearMonth@ pattern
29fromYearMonth :: Year -> MonthOfYear -> Month
30fromYearMonth = YearMonth
31
32-- | Part of @YearMonth@ pattern
33toYearMonth :: Month -> (Year, MonthOfYear)
34toYearMonth (YearMonth y m) = (y, m)
35
36-- | Part of 'MonthDay' pattern
37fromMonthDay :: Month -> DayOfMonth -> Day
38fromMonthDay = MonthDay
39
40-- | Part of 'MonthDay' pattern
41toMonthDay :: Day -> (Month,DayOfMonth)
42toMonthDay (MonthDay m d) = (m, d)
43
44#else
45
46#if MIN_VERSION_time(1,9,0)
47import Data.Time.Format.Internal
48#else
49import Data.Time.Format
50#endif
51
52import Data.Time.Calendar
53import Data.Time.Calendar.Julian
54import Data.Time.Calendar.Types
55-- import Data.Time.Calendar.Days
56import Data.Time.Calendar.Private
57import Data.Data
58import Data.Fixed
59import Text.Read
60import Text.ParserCombinators.ReadP
61import Control.DeepSeq (NFData (..))
62import Data.Ix (Ix (..))
63
64-- | An absolute count of common calendar months.
65-- Number is equal to @(year * 12) + (monthOfYear - 1)@.
66newtype Month = MkMonth Integer deriving (Eq, Ord, Data, Typeable)
67
68instance NFData Month where
69    rnf (MkMonth m) = rnf m
70
71instance Enum Month where
72    succ (MkMonth a) = MkMonth (succ a)
73    pred (MkMonth a) = MkMonth (pred a)
74    toEnum = MkMonth . toEnum
75    fromEnum (MkMonth a) = fromEnum a
76    enumFrom (MkMonth a) = fmap MkMonth (enumFrom a)
77    enumFromThen (MkMonth a) (MkMonth b) = fmap MkMonth (enumFromThen a b)
78    enumFromTo (MkMonth a) (MkMonth b) = fmap MkMonth (enumFromTo a b)
79    enumFromThenTo (MkMonth a) (MkMonth b) (MkMonth c) =
80        fmap MkMonth (enumFromThenTo a b c)
81
82instance Ix Month where
83    range (MkMonth a, MkMonth b) = fmap MkMonth (range (a, b))
84    index (MkMonth a, MkMonth b) (MkMonth c) = index (a, b) c
85    inRange (MkMonth a, MkMonth b) (MkMonth c) = inRange (a, b) c
86    rangeSize (MkMonth a, MkMonth b) = rangeSize (a, b)
87
88-- | Show as @yyyy-mm@.
89instance Show Month where
90    show ym = case toYearMonth ym of
91        (y, m) -> show4 y ++ "-" ++ show2 m
92
93-- | Read as @yyyy-mm@.
94instance Read Month where
95    readPrec = do
96        y <- readPrec
97        _ <- lift $ char '-'
98        m <- readPrec
99        return $ fromYearMonth y m
100
101-------------------------------------------------------------------------------
102-- ForematTime Month
103-------------------------------------------------------------------------------
104
105toSomeDay :: Month -> Day
106toSomeDay (MkMonth m) =
107    let (y,my) = divMod' m 12
108    in fromGregorian y (succ (fromInteger my)) 1
109
110#if MIN_VERSION_time(1,9,0)
111#define FORMAT_OPTS fo
112#elif MIN_VERSION_time(1,8,0)
113#define FORMAT_OPTS tl mpo i
114#else
115#define FORMAT_OPTS tl mpo
116#endif
117
118#if MIN_VERSION_time(1,9,0)
119#define FORMAT_ARG _arg
120#else
121#define FORMAT_ARG
122#endif
123
124instance FormatTime Month where
125    -- Year Count
126    formatCharacter FORMAT_ARG 'Y' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'Y')
127    formatCharacter FORMAT_ARG 'y' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'y')
128    formatCharacter FORMAT_ARG 'c' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'c')
129    -- Month of Year
130    formatCharacter FORMAT_ARG 'B' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'B')
131    formatCharacter FORMAT_ARG 'b' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'b')
132    formatCharacter FORMAT_ARG 'h' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'h')
133    formatCharacter FORMAT_ARG 'm' = fmap (\f FORMAT_OPTS d -> f FORMAT_OPTS (toSomeDay d)) (formatCharacter FORMAT_ARG 'm')
134
135    formatCharacter FORMAT_ARG _  = Nothing
136
137addMonths :: Integer -> Month -> Month
138addMonths n (MkMonth a) = MkMonth $ a + n
139
140diffMonths :: Month -> Month -> Integer
141diffMonths (MkMonth a) (MkMonth b) = a - b
142
143fromYearMonthValid :: Year -> MonthOfYear -> Maybe Month
144fromYearMonthValid y my = do
145    my' <- clipValid 1 12 my
146    return $ fromYearMonth y my'
147
148-- | Part of @YearMonth@ pattern
149fromYearMonth :: Year -> MonthOfYear -> Month
150fromYearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my)
151
152-- | Part of @YearMonth@ pattern
153toYearMonth :: Month -> (Year, MonthOfYear)
154toYearMonth (MkMonth m) = case divMod' m 12 of
155    (y, my) -> (y, succ (fromInteger my))
156
157#if __GLASGOW_HASKELL__ >= 710
158-- | Bidirectional abstract constructor.
159-- Invalid months of year will be clipped to the correct range.
160pattern YearMonth :: Year -> MonthOfYear -> Month
161pattern YearMonth y my <- (toYearMonth -> (y, my))
162  where YearMonth y my = fromYearMonth y my
163
164#if __GLASGOW_HASKELL__ >= 802
165{-# COMPLETE YearMonth #-}
166#endif
167#endif
168
169-- | Part of 'MonthDay' pattern
170toMonthDay :: Day -> (Month,DayOfMonth)
171toMonthDay d = case toGregorian d of
172    (y, my, dm) -> (fromYearMonth y my, dm)
173
174-- | Part of 'MonthDay' pattern
175fromMonthDay :: Month -> DayOfMonth -> Day
176fromMonthDay m dm = case toYearMonth m of
177    (y, my) -> fromGregorian y my dm
178
179fromMonthDayValid :: Month -> DayOfMonth -> Maybe Day
180fromMonthDayValid m dm = case toYearMonth m of
181    (y, my) -> fromGregorianValid y my dm
182
183#if __GLASGOW_HASKELL__ >= 710
184-- | Bidirectional abstract constructor.
185-- Invalid days of month will be clipped to the correct range.
186pattern MonthDay :: Month -> DayOfMonth -> Day
187pattern MonthDay m dm <- (toMonthDay -> (m,dm)) where
188    MonthDay (YearMonth y my) dm = fromGregorian y my dm
189
190
191#if __GLASGOW_HASKELL__ >= 802
192{-# COMPLETE MonthDay #-}
193#endif
194#endif
195
196#endif
197