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