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