1{-# LANGUAGE CPP #-} 2#if __GLASGOW_HASKELL__ >= 710 3{-# LANGUAGE PatternSynonyms #-} 4{-# LANGUAGE ViewPatterns #-} 5#endif 6module Data.Time.Calendar.Julian.Compat ( 7 Year, MonthOfYear, DayOfMonth, DayOfYear, 8 9 -- JulianYearDay 10 toJulianYearAndDay, 11 fromJulianYearAndDay, 12 fromJulianYearAndDayValid, 13 showJulianYearAndDay, 14 isJulianLeapYear, 15 16 toJulian,fromJulian, 17#if __GLASGOW_HASKELL__ >= 710 18 pattern JulianYearMonthDay, 19#endif 20 fromJulianValid,showJulian,julianMonthLength, 21 22 -- calendrical arithmetic 23 -- e.g. "one month after March 31st" 24 addJulianMonthsClip,addJulianMonthsRollOver, 25 addJulianYearsClip,addJulianYearsRollOver, 26 addJulianDurationClip,addJulianDurationRollOver, 27 diffJulianDurationClip,diffJulianDurationRollOver, 28) where 29 30import Data.Time.Orphans () 31 32import Data.Time.Calendar.Julian 33import Data.Time.Calendar.Compat 34 35#if !MIN_VERSION_time(1,11,0) 36import Data.Time.Calendar.Types 37#endif 38 39#if !MIN_VERSION_time(1,9,0) 40 41-- | Add months (clipped to last day), then add days 42addJulianDurationClip :: CalendarDiffDays -> Day -> Day 43addJulianDurationClip (CalendarDiffDays m d) day = addDays d $ addJulianMonthsClip m day 44 45-- | Add months (rolling over to next month), then add days 46addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day 47addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMonthsRollOver m day 48 49-- | Calendrical difference, with as many whole months as possible 50diffJulianDurationClip :: Day -> Day -> CalendarDiffDays 51diffJulianDurationClip day2 day1 = let 52 (y1,m1,d1) = toJulian day1 53 (y2,m2,d2) = toJulian day2 54 ym1 = y1 * 12 + toInteger m1 55 ym2 = y2 * 12 + toInteger m2 56 ymdiff = ym2 - ym1 57 ymAllowed = 58 if day2 >= day1 then 59 if d2 >= d1 then ymdiff else ymdiff - 1 60 else if d2 <= d1 then ymdiff else ymdiff + 1 61 dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 62 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 63 64-- | Calendrical difference, with as many whole months as possible. 65-- Same as 'diffJulianDurationClip' for positive durations. 66diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays 67diffJulianDurationRollOver day2 day1 = let 68 (y1,m1,d1) = toJulian day1 69 (y2,m2,d2) = toJulian day2 70 ym1 = y1 * 12 + toInteger m1 71 ym2 = y2 * 12 + toInteger m2 72 ymdiff = ym2 - ym1 73 ymAllowed = 74 if day2 >= day1 then 75 if d2 >= d1 then ymdiff else ymdiff - 1 76 else if d2 <= d1 then ymdiff else ymdiff + 1 77 dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 78 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 79 80#endif 81 82#if !MIN_VERSION_time(1,11,0) 83#if __GLASGOW_HASKELL__ >= 710 84-- | Bidirectional abstract constructor for the proleptic Julian calendar. 85-- Invalid values will be clipped to the correct range, month first, then day. 86pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day 87pattern JulianYearMonthDay y m d <- (toJulian -> (y,m,d)) where 88 JulianYearMonthDay y m d = fromJulian y m d 89 90#if __GLASGOW_HASKELL__ >= 802 91{-# COMPLETE JulianYearMonthDay #-} 92#endif 93#endif 94#endif 95