022435d63fab4d557c5de78fe473b80e091b86c0
[packages/time.git] / lib / Data / Time / Calendar / Gregorian.hs
1 {-# OPTIONS -fno-warn-orphans #-}
2 module Data.Time.Calendar.Gregorian
3 (
4 -- * Gregorian calendar
5 toGregorian,fromGregorian,fromGregorianValid,showGregorian,gregorianMonthLength,
6
7 -- calendrical arithmetic
8 -- e.g. "one month after March 31st"
9 addGregorianMonthsClip,addGregorianMonthsRollOver,
10 addGregorianYearsClip,addGregorianYearsRollOver,
11 addGregorianDurationClip,addGregorianDurationRollOver,
12 diffGregorianDurationClip,diffGregorianDurationRollOver,
13
14 -- re-exported from OrdinalDate
15 isLeapYear
16 ) where
17
18 import Data.Time.Calendar.MonthDay
19 import Data.Time.Calendar.OrdinalDate
20 import Data.Time.Calendar.Days
21 import Data.Time.Calendar.CalendarDiffDays
22 import Data.Time.Calendar.Private
23
24 -- | Convert to proleptic Gregorian calendar. First element of result is year, second month number (1-12), third day (1-31).
25 toGregorian :: Day -> (Integer,Int,Int)
26 toGregorian date = (year,month,day) where
27 (year,yd) = toOrdinalDate date
28 (month,day) = dayOfYearToMonthAndDay (isLeapYear year) yd
29
30 -- | Convert from proleptic Gregorian calendar. First argument is year, second month number (1-12), third day (1-31).
31 -- Invalid values will be clipped to the correct range, month first, then day.
32 fromGregorian :: Integer -> Int -> Int -> Day
33 fromGregorian year month day = fromOrdinalDate year (monthAndDayToDayOfYear (isLeapYear year) month day)
34
35 -- | Convert from proleptic Gregorian calendar. First argument is year, second month number (1-12), third day (1-31).
36 -- Invalid values will return Nothing
37 fromGregorianValid :: Integer -> Int -> Int -> Maybe Day
38 fromGregorianValid year month day = do
39 doy <- monthAndDayToDayOfYearValid (isLeapYear year) month day
40 fromOrdinalDateValid year doy
41
42 -- | Show in ISO 8601 format (yyyy-mm-dd)
43 showGregorian :: Day -> String
44 showGregorian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d) where
45 (y,m,d) = toGregorian date
46
47 -- | The number of days in a given month according to the proleptic Gregorian calendar. First argument is year, second is month.
48 gregorianMonthLength :: Integer -> Int -> Int
49 gregorianMonthLength year = monthLength (isLeapYear year)
50
51 rolloverMonths :: (Integer,Integer) -> (Integer,Int)
52 rolloverMonths (y,m) = (y + (div (m - 1) 12),fromIntegral (mod (m - 1) 12) + 1)
53
54 addGregorianMonths :: Integer -> Day -> (Integer,Int,Int)
55 addGregorianMonths n day = (y',m',d) where
56 (y,m,d) = toGregorian day
57 (y',m') = rolloverMonths (y,fromIntegral m + n)
58
59 -- | Add months, with days past the last day of the month clipped to the last day.
60 -- For instance, 2005-01-30 + 1 month = 2005-02-28.
61 addGregorianMonthsClip :: Integer -> Day -> Day
62 addGregorianMonthsClip n day = fromGregorian y m d where
63 (y,m,d) = addGregorianMonths n day
64
65 -- | Add months, with days past the last day of the month rolling over to the next month.
66 -- For instance, 2005-01-30 + 1 month = 2005-03-02.
67 addGregorianMonthsRollOver :: Integer -> Day -> Day
68 addGregorianMonthsRollOver n day = addDays (fromIntegral d - 1) (fromGregorian y m 1) where
69 (y,m,d) = addGregorianMonths n day
70
71 -- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary.
72 -- For instance, 2004-02-29 + 2 years = 2006-02-28.
73 addGregorianYearsClip :: Integer -> Day -> Day
74 addGregorianYearsClip n = addGregorianMonthsClip (n * 12)
75
76 -- | Add years, matching month and day, with Feb 29th rolled over to Mar 1st if necessary.
77 -- For instance, 2004-02-29 + 2 years = 2006-03-01.
78 addGregorianYearsRollOver :: Integer -> Day -> Day
79 addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12)
80
81 -- | Add months (clipped to last day), then add days
82 addGregorianDurationClip :: CalendarDiffDays -> Day -> Day
83 addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day
84
85 -- | Add months (rolling over to next month), then add days
86 addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day
87 addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day
88
89 -- | Calendrical difference, with as many whole months as possible
90 diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
91 diffGregorianDurationClip day2 day1 = let
92 (y1,m1,d1) = toGregorian day1
93 (y2,m2,d2) = toGregorian day2
94 ym1 = y1 * 12 + toInteger m1
95 ym2 = y2 * 12 + toInteger m2
96 ymdiff = ym2 - ym1
97 ymAllowed =
98 if day2 >= day1 then
99 if d2 >= d1 then ymdiff else ymdiff - 1
100 else if d2 <= d1 then ymdiff else ymdiff + 1
101 dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1
102 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
103
104 -- | Calendrical difference, with as many whole months as possible.
105 -- Same as 'diffGregorianDurationClip' for positive durations.
106 diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
107 diffGregorianDurationRollOver day2 day1 = let
108 (y1,m1,d1) = toGregorian day1
109 (y2,m2,d2) = toGregorian day2
110 ym1 = y1 * 12 + toInteger m1
111 ym2 = y2 * 12 + toInteger m2
112 ymdiff = ym2 - ym1
113 ymAllowed =
114 if day2 >= day1 then
115 if d2 >= d1 then ymdiff else ymdiff - 1
116 else if d2 <= d1 then ymdiff else ymdiff + 1
117 dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
118 in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
119
120 -- orphan instance
121 instance Show Day where
122 show = showGregorian