new CalendarDuration type (for #40)
authorAshley Yakeley <ashley@semantic.org>
Fri, 12 Jan 2018 06:47:04 +0000 (22:47 -0800)
committerAshley Yakeley <ashley@semantic.org>
Fri, 12 Jan 2018 06:47:04 +0000 (22:47 -0800)
changelog.md
lib/Data/Time/Calendar.hs
lib/Data/Time/Calendar/Duration.hs [new file with mode: 0644]
lib/Data/Time/Calendar/Gregorian.hs
lib/Data/Time/Calendar/Julian.hs
test/main/Main.hs
test/main/Test/Arbitrary.hs [new file with mode: 0644]
test/main/Test/Calendar/Duration.hs [new file with mode: 0644]
test/main/Test/Format/ParseTime.hs
time.cabal

index ad51255..6d7b29b 100644 (file)
@@ -2,6 +2,7 @@
 
 ## [1.9]
 - new DayOfWeek type
+- new CalendarDuration type
 - formatting: %Ez and %EZ for ±HH:MM format
 - parseTimeM: use MonadFail constraint when supported
 - parsing: reject invalid (and empty) time-zones with %z and %Z
index f211409..77a844f 100644 (file)
@@ -1,11 +1,13 @@
 module Data.Time.Calendar
 (
     module Data.Time.Calendar.Days,
+    module Data.Time.Calendar.Duration,
     module Data.Time.Calendar.Gregorian,
     module Data.Time.Calendar.Week
 ) where
 
 import Data.Time.Calendar.Days
+import Data.Time.Calendar.Duration
 import Data.Time.Calendar.Gregorian
 import Data.Time.Calendar.Week
 import Data.Time.Format()
diff --git a/lib/Data/Time/Calendar/Duration.hs b/lib/Data/Time/Calendar/Duration.hs
new file mode 100644 (file)
index 0000000..71caf4c
--- /dev/null
@@ -0,0 +1,40 @@
+module Data.Time.Calendar.Duration
+    (
+        -- * Calendar Duration
+        module Data.Time.Calendar.Duration
+    ) where
+
+data CalendarDuration = CalendarDuration
+    { calendarMonths :: Integer
+    , calendarDays :: Integer
+    } deriving Eq
+
+-- | Additive
+instance Monoid CalendarDuration where
+    mempty = CalendarDuration 0 0
+    mappend (CalendarDuration m1 d1) (CalendarDuration m2 d2) = CalendarDuration (m1 + m2) (d1 + d2)
+
+-- | Show in ISO 8601 "PyyYmmMddD" format.
+instance Show CalendarDuration where
+    show dur@(CalendarDuration m d) = let
+        (y,my) = quotRem m 12
+        ys = if y == 0 then "" else show y ++ "Y"
+        ms = if my == 0 then "" else show my ++ "M"
+        ds = if d == 0 then "" else show d ++ "D"
+        in if dur == mempty then "P0D" else "P" ++ ys ++ ms ++ ds
+
+calendarDay :: CalendarDuration
+calendarDay = CalendarDuration 0 1
+
+calendarWeek :: CalendarDuration
+calendarWeek = CalendarDuration 0 7
+
+calendarMonth :: CalendarDuration
+calendarMonth = CalendarDuration 1 0
+
+calendarYear :: CalendarDuration
+calendarYear = CalendarDuration 12 0
+
+-- | Scale by a factor. Note that @scaleCalendarDuration (-1)@ will not perfectly invert a duration, due to variable month lengths.
+scaleCalendarDuration :: Integer -> CalendarDuration -> CalendarDuration
+scaleCalendarDuration k (CalendarDuration m d) = CalendarDuration (k * m) (k * d)
index 2a29e8e..df173d3 100644 (file)
@@ -10,6 +10,8 @@ module Data.Time.Calendar.Gregorian
     -- e.g. "one month after March 31st"
     addGregorianMonthsClip,addGregorianMonthsRollOver,
     addGregorianYearsClip,addGregorianYearsRollOver,
+    addGregorianDurationClip,addGregorianDurationRollOver,
+    diffGregorianDurationClip,diffGregorianDurationRollOver,
 
     -- re-exported from OrdinalDate
     isLeapYear
@@ -18,6 +20,7 @@ module Data.Time.Calendar.Gregorian
 import Data.Time.Calendar.MonthDay
 import Data.Time.Calendar.OrdinalDate
 import Data.Time.Calendar.Days
+import Data.Time.Calendar.Duration
 import Data.Time.Calendar.Private
 
 -- | Convert to proleptic Gregorian calendar. First element of result is year, second month number (1-12), third day (1-31).
@@ -77,6 +80,45 @@ addGregorianYearsClip n = addGregorianMonthsClip (n * 12)
 addGregorianYearsRollOver :: Integer -> Day -> Day
 addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12)
 
+-- | Add months (clipped to last day), then add days
+addGregorianDurationClip :: CalendarDuration -> Day -> Day
+addGregorianDurationClip (CalendarDuration m d) day = addDays d $ addGregorianMonthsClip m day
+
+-- | Add months (rolling over to next month), then add days
+addGregorianDurationRollOver :: CalendarDuration -> Day -> Day
+addGregorianDurationRollOver (CalendarDuration m d) day = addDays d $ addGregorianMonthsRollOver m day
+
+-- | Calendrical difference, with as many whole months as possible
+diffGregorianDurationClip :: Day -> Day -> CalendarDuration
+diffGregorianDurationClip 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 = addGregorianDurationClip (CalendarDuration ymAllowed 0) day1
+    in CalendarDuration ymAllowed $ diffDays day2 dayAllowed
+
+-- | Calendrical difference, with as many whole months as possible.
+-- Same as 'diffGregorianDurationClip' for positive durations.
+diffGregorianDurationRollOver :: Day -> Day -> CalendarDuration
+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 (CalendarDuration ymAllowed 0) day1
+    in CalendarDuration ymAllowed $ diffDays day2 dayAllowed
+
 -- orphan instance
 instance Show Day where
     show = showGregorian
index e308da0..bf8daeb 100644 (file)
@@ -7,12 +7,15 @@ module Data.Time.Calendar.Julian
     -- calendrical arithmetic
     -- e.g. "one month after March 31st"
     addJulianMonthsClip,addJulianMonthsRollOver,
-    addJulianYearsClip,addJulianYearsRollOver
+    addJulianYearsClip,addJulianYearsRollOver,
+    addJulianDurationClip,addJulianDurationRollOver,
+    diffJulianDurationClip,diffJulianDurationRollOver,
 ) where
 
 import Data.Time.Calendar.MonthDay
 import Data.Time.Calendar.JulianYearDay
 import Data.Time.Calendar.Days
+import Data.Time.Calendar.Duration
 import Data.Time.Calendar.Private
 
 -- | Convert to proleptic Julian calendar. First element of result is year, second month number (1-12), third day (1-31).
@@ -71,3 +74,42 @@ addJulianYearsClip n = addJulianMonthsClip (n * 12)
 -- For instance, 2004-02-29 + 2 years = 2006-03-01.
 addJulianYearsRollOver :: Integer -> Day -> Day
 addJulianYearsRollOver n = addJulianMonthsRollOver (n * 12)
+
+-- | Add months (clipped to last day), then add days
+addJulianDurationClip :: CalendarDuration -> Day -> Day
+addJulianDurationClip (CalendarDuration m d) day = addDays d $ addJulianMonthsClip m day
+
+-- | Add months (rolling over to next month), then add days
+addJulianDurationRollOver :: CalendarDuration -> Day -> Day
+addJulianDurationRollOver (CalendarDuration m d) day = addDays d $ addJulianMonthsRollOver m day
+
+-- | Calendrical difference, with as many whole months as possible
+diffJulianDurationClip :: Day -> Day -> CalendarDuration
+diffJulianDurationClip 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 = addJulianDurationClip (CalendarDuration ymAllowed 0) day1
+    in CalendarDuration ymAllowed $ diffDays day2 dayAllowed
+
+-- | Calendrical difference, with as many whole months as possible.
+-- Same as 'diffJulianDurationClip' for positive durations.
+diffJulianDurationRollOver :: Day -> Day -> CalendarDuration
+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 (CalendarDuration ymAllowed 0) day1
+    in CalendarDuration ymAllowed $ diffDays day2 dayAllowed
index a8f4cc5..bd7dc09 100644 (file)
@@ -5,6 +5,7 @@ import Test.Calendar.AddDays
 import Test.Calendar.Calendars
 import Test.Calendar.ClipDates
 import Test.Calendar.ConvertBack
+import Test.Calendar.Duration
 import Test.Calendar.Easter
 import Test.Calendar.LongWeekYears
 import Test.Calendar.MonthDay
@@ -29,7 +30,8 @@ tests = testGroup "Time" [
         testMonthDay,
         testEaster,
         testValid,
-        testWeek
+        testWeek,
+        testDuration
         ],
     testGroup "Clock" [
         testClockConversion,
diff --git a/test/main/Test/Arbitrary.hs b/test/main/Test/Arbitrary.hs
new file mode 100644 (file)
index 0000000..43058c6
--- /dev/null
@@ -0,0 +1,83 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Test.Arbitrary where
+
+import Control.Monad
+import Data.Ratio
+import Data.Time
+import Data.Time.Clock.POSIX
+import Test.Tasty.QuickCheck hiding (reason)
+
+instance Arbitrary Day where
+    arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
+    shrink day = let
+        (y, m, d) = toGregorian day
+        dayShrink =
+            if d > 1
+                then [fromGregorian y m (d - 1)]
+                else []
+        monthShrink =
+            if m > 1
+                then [fromGregorian y (m - 1) d]
+                else []
+        yearShrink =
+            if y > 2000
+                then [fromGregorian (y - 1) m d]
+                else if y < 2000
+                         then [fromGregorian (y + 1) m d]
+                         else []
+        in dayShrink ++ monthShrink ++ yearShrink
+
+instance CoArbitrary Day where
+    coarbitrary (ModifiedJulianDay d) = coarbitrary d
+
+instance Arbitrary DiffTime where
+    arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second
+      where
+        intSecs = liftM secondsToDiffTime' $ choose (0, 86400)
+        fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10 ^ (12 :: Int))
+        secondsToDiffTime' :: Integer -> DiffTime
+        secondsToDiffTime' = fromInteger
+        picosecondsToDiffTime' :: Integer -> DiffTime
+        picosecondsToDiffTime' x = fromRational (x % 10 ^ (12 :: Int))
+
+instance CoArbitrary DiffTime where
+    coarbitrary t = coarbitrary (fromEnum t)
+
+instance Arbitrary TimeOfDay where
+    arbitrary = liftM timeToTimeOfDay arbitrary
+
+instance CoArbitrary TimeOfDay where
+    coarbitrary t = coarbitrary (timeOfDayToTime t)
+
+instance Arbitrary LocalTime where
+    arbitrary = liftM2 LocalTime arbitrary arbitrary
+
+instance CoArbitrary LocalTime where
+    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer)
+
+instance Arbitrary TimeZone where
+    arbitrary = liftM minutesToTimeZone $ choose (-720, 720)
+
+instance CoArbitrary TimeZone where
+    coarbitrary tz = coarbitrary (timeZoneMinutes tz)
+
+instance Arbitrary ZonedTime where
+    arbitrary = liftM2 ZonedTime arbitrary arbitrary
+
+instance CoArbitrary ZonedTime where
+    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer)
+
+instance Arbitrary UTCTime where
+    arbitrary = liftM2 UTCTime arbitrary arbitrary
+
+instance CoArbitrary UTCTime where
+    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds t) :: Integer)
+
+instance Arbitrary UniversalTime where
+    arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) -- 1000-01-1 to 9999-12-31
+      where
+        k = 86400
+
+instance CoArbitrary UniversalTime where
+    coarbitrary (ModJulianDate d) = coarbitrary d
diff --git a/test/main/Test/Calendar/Duration.hs b/test/main/Test/Calendar/Duration.hs
new file mode 100644 (file)
index 0000000..d5729d7
--- /dev/null
@@ -0,0 +1,46 @@
+module Test.Calendar.Duration
+    ( testDuration
+    ) where
+
+import Data.Time.Calendar
+import Data.Time.Calendar.Julian
+import Test.Arbitrary ()
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck hiding (reason)
+
+testAddDiff :: TestTree
+testAddDiff =
+    testGroup
+        "add diff"
+        [ testProperty "add diff GregorianDurationClip" $ \day1 day2 ->
+              addGregorianDurationClip (diffGregorianDurationClip day2 day1) day1 == day2
+        , testProperty "add diff GregorianDurationRollOver" $ \day1 day2 ->
+              addGregorianDurationRollOver (diffGregorianDurationRollOver day2 day1) day1 == day2
+        , testProperty "add diff JulianDurationClip" $ \day1 day2 ->
+              addJulianDurationClip (diffJulianDurationClip day2 day1) day1 == day2
+        , testProperty "add diff JulianDurationRollOver" $ \day1 day2 ->
+              addJulianDurationRollOver (diffJulianDurationRollOver day2 day1) day1 == day2
+        ]
+
+testClip :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree
+testClip (y1,m1,d1) (y2,m2,d2) (em, ed) = let
+    day1 = fromGregorian y1 m1 d1
+    day2 = fromGregorian y2 m2 d2
+    expected = CalendarDuration em ed
+    found = diffGregorianDurationClip day1 day2
+    in testCase (show day1 ++ " - " ++ show day2) $ assertEqual "" expected found
+
+testDiffs :: TestTree
+testDiffs =
+    testGroup
+        "diffs"
+        [ testClip (2017, 04, 07) (2017, 04, 07) (0, 0)
+        , testClip (2017, 04, 07) (2017, 04, 01) (0, 6)
+        , testClip (2017, 04, 01) (2017, 04, 07) (0, -6)
+        , testClip (2017, 04, 07) (2017, 02, 01) (2, 6)
+        , testClip (2017, 02, 01) (2017, 04, 07) (-2, -6)
+        ]
+
+testDuration :: TestTree
+testDuration = testGroup "CalendarDuration" [testAddDiff, testDiffs]
index 5a21531..6bd1f1f 100644 (file)
@@ -3,16 +3,15 @@ module Test.Format.ParseTime(testParseTime,test_parse_format) where
 
 import Control.Monad
 import Data.Char
-import Data.Ratio
 import Data.Time
 import Data.Time.Calendar.OrdinalDate
 import Data.Time.Calendar.WeekDate
-import Data.Time.Clock.POSIX
 import Test.QuickCheck.Property
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck hiding (reason)
 import Test.TestUtil
+import Test.Arbitrary()
 
 
 testParseTime :: TestTree
@@ -233,61 +232,6 @@ parse sp f t = parseTimeM sp defaultTimeLocale f t
 format :: (FormatTime t) => String -> t -> String
 format f t = formatTime defaultTimeLocale f t
 
-instance Arbitrary Day where
-    arbitrary = liftM ModifiedJulianDay $ choose (-313698, 2973483) -- 1000-01-1 to 9999-12-31
-
-instance CoArbitrary Day where
-    coarbitrary (ModifiedJulianDay d) = coarbitrary d
-
-instance Arbitrary DiffTime where
-    arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second
-        where intSecs = liftM secondsToDiffTime' $ choose (0, 86400)
-              fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10^(12::Int))
-              secondsToDiffTime' :: Integer -> DiffTime
-              secondsToDiffTime' = fromInteger
-              picosecondsToDiffTime' :: Integer -> DiffTime
-              picosecondsToDiffTime' x = fromRational (x % 10^(12::Int))
-
-instance CoArbitrary DiffTime where
-    coarbitrary t = coarbitrary (fromEnum t)
-
-instance Arbitrary TimeOfDay where
-    arbitrary = liftM timeToTimeOfDay arbitrary
-
-instance CoArbitrary TimeOfDay where
-    coarbitrary t = coarbitrary (timeOfDayToTime t)
-
-instance Arbitrary LocalTime where
-    arbitrary = liftM2 LocalTime arbitrary arbitrary
-
-instance CoArbitrary LocalTime where
-    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer)
-
-instance Arbitrary TimeZone where
-    arbitrary = liftM minutesToTimeZone $ choose (-720,720)
-
-instance CoArbitrary TimeZone where
-    coarbitrary tz = coarbitrary (timeZoneMinutes tz)
-
-instance Arbitrary ZonedTime where
-    arbitrary = liftM2 ZonedTime arbitrary arbitrary
-
-instance CoArbitrary ZonedTime where
-    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer)
-
-instance Arbitrary UTCTime where
-    arbitrary = liftM2 UTCTime arbitrary arbitrary
-
-instance CoArbitrary UTCTime where
-    coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds t) :: Integer)
-
-instance Arbitrary UniversalTime where
-    arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) where -- 1000-01-1 to 9999-12-31
-        k = 86400
-
-instance CoArbitrary UniversalTime where
-    coarbitrary (ModJulianDate d) = coarbitrary d
-
 -- missing from the time package
 instance Eq ZonedTime where
     ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2
index 804234f..bb77c9a 100644 (file)
@@ -74,6 +74,7 @@ library
         Data.Time.Calendar.Private,
         Data.Time.Calendar.Days,
         Data.Time.Calendar.Gregorian,
+        Data.Time.Calendar.Duration,
         Data.Time.Calendar.Week,
         Data.Time.Calendar.JulianYearDay,
         Data.Time.Clock.Internal.DiffTime,
@@ -138,6 +139,7 @@ test-suite test-main
     main-is: Main.hs
     other-modules:
         Test.TestUtil
+        Test.Arbitrary
         Test.Calendar.AddDays
         Test.Calendar.AddDaysRef
         Test.Calendar.Calendars
@@ -145,6 +147,7 @@ test-suite test-main
         Test.Calendar.ClipDates
         Test.Calendar.ClipDatesRef
         Test.Calendar.ConvertBack
+        Test.Calendar.Duration
         Test.Calendar.Easter
         Test.Calendar.EasterRef
         Test.Calendar.LongWeekYears