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