RollOver fix

src/Data/Time/Calendar/Compat.hs

@@ -63,7 +63,12 @@ module Data.Time.Calendar.Compat (
     pattern YearMonthDay,
 ) where
 
+#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_time(1,14,0)
+import Data.Time.Calendar hiding (diffGregorianDurationRollOver)
+#else
 import Data.Time.Calendar
+#endif
+
 import Data.Time.Format
 import Data.Time.Orphans ()
 
@@ -174,23 +179,34 @@ diffGregorianDurationClip day2 day1 = let
         else if d2 <= d1 then ymdiff else ymdiff + 1
     dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1
     in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
+#endif
 
+#if !MIN_VERSION_time(1,14,0)
 -- | Calendrical difference, with as many whole months as possible.
--- Same as 'diffGregorianDurationClip' for positive durations.
 diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
-diffGregorianDurationRollOver day2 day1 = let
-    (y1,m1,d1) = toGregorian day1
-    (y2,m2,d2) = toGregorian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
-    ymdiff = ym2 - ym1
-    ymAllowed =
-        if day2 >= day1 then
-        if d2 >= d1 then ymdiff else ymdiff - 1
-        else if d2 <= d1 then ymdiff else ymdiff + 1
-    dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
-    in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
-
+diffGregorianDurationRollOver day2 day1 =
+    let
+        (y1, m1, _) = toGregorian day1
+        (y2, m2, _) = toGregorian day2
+        ym1 = y1 * 12 + toInteger m1
+        ym2 = y2 * 12 + toInteger m2
+        ymdiff = ym2 - ym1
+        findpos mdiff =
+            let
+                dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1
+                dd = diffDays day2 dayAllowed
+            in
+                if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff)
+        findneg mdiff =
+            let
+                dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1
+                dd = diffDays day2 dayAllowed
+            in
+                if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff)
+    in
+        if day2 >= day1
+            then findpos ymdiff
+            else findneg ymdiff
 #endif
 
 #if !MIN_VERSION_time(1,11,0)

src/Data/Time/Calendar/Julian/Compat.hs

@@ -25,7 +25,12 @@ module Data.Time.Calendar.Julian.Compat (
 
 import Data.Time.Orphans ()
 
+#if MIN_VERSION_time(1,9,0) && !MIN_VERSION_time(1,14,0)
+import Data.Time.Calendar.Julian hiding (diffJulianDurationRollOver)
+#else
 import Data.Time.Calendar.Julian
+#endif
+
 import Data.Time.Calendar.Compat
 
 #if !MIN_VERSION_time(1,11,0)
@@ -57,22 +62,34 @@ diffJulianDurationClip day2 day1 = let
     dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1
     in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
 
--- | Calendrical difference, with as many whole months as possible.
--- Same as 'diffJulianDurationClip' for positive durations.
-diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
-diffJulianDurationRollOver day2 day1 = let
-    (y1,m1,d1) = toJulian day1
-    (y2,m2,d2) = toJulian day2
-    ym1 = y1 * 12 + toInteger m1
-    ym2 = y2 * 12 + toInteger m2
-    ymdiff = ym2 - ym1
-    ymAllowed =
-        if day2 >= day1 then
-        if d2 >= d1 then ymdiff else ymdiff - 1
-        else if d2 <= d1 then ymdiff else ymdiff + 1
-    dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
-    in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
+#endif
 
+#if !MIN_VERSION_time(1,14,0)
+
+diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
+diffJulianDurationRollOver day2 day1 =
+    let
+        (y1, m1, _) = toJulian day1
+        (y2, m2, _) = toJulian day2
+        ym1 = y1 * 12 + toInteger m1
+        ym2 = y2 * 12 + toInteger m2
+        ymdiff = ym2 - ym1
+        findpos mdiff =
+            let
+                dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1
+                dd = diffDays day2 dayAllowed
+            in
+                if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff)
+        findneg mdiff =
+            let
+                dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1
+                dd = diffDays day2 dayAllowed
+            in
+                if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff)
+    in
+        if day2 >= day1
+            then findpos ymdiff
+            else findneg ymdiff
 #endif
 
 #if !MIN_VERSION_time(1,11,0)