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