diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,12 @@ # Changelog for interval-algebra +## 1.1.1 + +* Modifies internals of `IntervalAlgebra.Arbitrary` module to give uniformity over support for `Integer` and `UTCTime` intervals, yielding better interval generators. Also bounds the `UTCTime` `utctDayTime` argument to `86399` rather than `86400` to avoid trivial and rare cases of property testing failures related to leap seconds. + ## 1.1.0 -* Fixes bug in `parseInterval`. For example, `parseInterval 0 0` parsed to a `Right (Interval (0, 0))`. Oops, the inequality of the should have been `y <= x` not `y < x`. This was fixed and a test added catch this error. +* Fixes bug in `parseInterval`. For example, `parseInterval 0 0` parsed to a `Right (Interval (0, 0))`. Oops, the inequality of the should have been `y <= x` not `y < x`. This was fixed and a test added to catch this error. ## 1.0.1 diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra -version: 1.1.0 +version: 1.1.1 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -6,55 +6,59 @@ Maintainer : bsaul@novisci.com Stability : experimental -} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + module IntervalAlgebra.Arbitrary() where -import Test.QuickCheck ( Arbitrary(arbitrary, shrink), - Gen, NonNegative ) -import GHC.Int ( Int ) -import GHC.Num -import GHC.Real -import GHC.Float -import Control.Applicative ( (<$>), liftA2 ) -import Control.Monad ( liftM2 ) -import IntervalAlgebra (Interval, beginerval) -import Data.Function ( (.), ($) ) -import Data.Fixed -import Data.Bool -import Data.Ord -import Data.Time as DT ( Day(ModifiedJulianDay) - , toModifiedJulianDay - , picosecondsToDiffTime - , secondsToDiffTime - , secondsToNominalDiffTime - , UTCTime(..), NominalDiffTime) +import Control.Applicative (liftA2, (<$>)) +import Control.Monad (liftM2) +import Data.Bool +import Data.Fixed +import Data.Function (($), (.)) +import Data.Ord +import Data.Time as DT (Day (ModifiedJulianDay), + NominalDiffTime, UTCTime (..), + DiffTime, + picosecondsToDiffTime, + secondsToDiffTime, + secondsToNominalDiffTime, + toModifiedJulianDay) +import GHC.Float +import GHC.Int (Int) +import GHC.Num +import GHC.Real +import IntervalAlgebra (Interval, beginerval) +import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, + arbitrarySizedNatural, resize) +-- NOTE: the default size for arbitrary :: Gen Int appears to be 30 +arbitrarySizedPositive :: Integral a => Gen a +arbitrarySizedPositive = (+ 1) <$> arbitrarySizedNatural + +maxDiffTime :: Int +maxDiffTime = 86400 + instance Arbitrary (Interval Int) where - arbitrary = liftM2 beginerval arbitrary arbitrary + arbitrary = liftM2 beginerval arbitrarySizedPositive arbitrary instance Arbitrary DT.Day where arbitrary = DT.ModifiedJulianDay <$> arbitrary shrink = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay - -withinDiffTimeRange :: Integer -> Integer -withinDiffTimeRange x - | x < 0 = 0 - | x > 86400 = 86400 - | otherwise = x - instance Arbitrary DT.NominalDiffTime where - arbitrary = fromInteger . withinDiffTimeRange <$> (arbitrary :: Gen Integer) + arbitrary = fromInteger <$> (maxDiffTime `resize` arbitrarySizedNatural) -instance Arbitrary DT.UTCTime where - arbitrary = liftA2 UTCTime - arbitrary - (secondsToDiffTime . withinDiffTimeRange <$> (arbitrary :: Gen Integer) ) +instance Arbitrary DT.DiffTime where + arbitrary = fromInteger <$> (maxDiffTime `resize` arbitrarySizedNatural) +instance Arbitrary DT.UTCTime where + -- resize in utctDayTime is to avoid rare leap-seconds-related failure, in + -- which e.g. 1858-12-31 00:00:00 UTC /= 1858-12-30 23:59:60 UTC + arbitrary = liftA2 UTCTime arbitrary (86399 `resize` arbitrary) + instance Arbitrary (Interval DT.Day) where arbitrary = liftM2 beginerval arbitrary arbitrary diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -16,7 +16,9 @@ , (===), (==>) , Arbitrary1 (liftArbitrary) , listOf - , orderedList) + , resize + , orderedList + , elements) import Data.List (sort) import IntervalAlgebra.Arbitrary ( ) import IntervalAlgebra ( Interval @@ -73,14 +75,25 @@ -- Types for testing +-- SmallInterval is just to test properties for which events of interest are so +-- rare QuickCheck gives up, e.g. filterEquals +data SmallInterval = SmallInterval { unSmall :: Interval Int } deriving (Show, Eq) + +instance Arbitrary SmallInterval where + arbitrary = SmallInterval . beginerval 0 <$> elements [0..10] + -- A "state" here is just used test formMeetingSequence newtype Events a = Events {getEvents :: [PairedInterval State a]} deriving (Eq, Show, Ord) + newtype State = State [Bool] deriving (Show, Eq) + instance Semigroup State where State x <> State y = State $ zipWith (||) x y + instance Monoid State where mempty = State [False, False, False] + type StateEvent a = PairedInterval State a @@ -94,8 +107,10 @@ instance Arbitrary State where arbitrary = State <$> suchThat (listOf arbitrary) (\x -> length x == 3) +-- SmallInterval again to address issue of generating from too large a possible +-- range of intervals instance Arbitrary (PairedInterval State Int) where - arbitrary = liftM2 makePairedInterval arbitrary arbitrary + arbitrary = liftM2 makePairedInterval arbitrary (unSmall <$> arbitrary) instance Arbitrary (Events Int) where arbitrary = Events <$> orderedList @@ -243,7 +258,7 @@ not (null es) ==> all (==Meets) (relationsL $ formMeetingSequence es) === True where es = getEvents x --- In the case that that the input has +-- In the case that the input has -- * at least one Before relation between consequent pairs -- * AND does not have any empty states -- @@ -259,7 +274,7 @@ where res = formMeetingSequence (getEvents x) beforeCount = lengthWhen (== Before) (relationsL (getEvents x)) emptyCount = lengthWhen (\x -> getPairData x == mempty ) res - lengthWhen f x = length $ filter f x + lengthWhen f = length . filter f -- Check that formMeetingSequence doesn't return an empty list unless input is -- empty. @@ -382,6 +397,18 @@ prop_clip_intersect x y = clip x y === intersect (min x y) (max x y) +-- NOTE: use this instead of prop_filterEquals +prop_small_filterEquals :: SmallInterval -> [SmallInterval] -> Property +prop_small_filterEquals x l = + not (null res) ==> and (fmap (predicate s i) res) === True + where + i = unSmall x + li = map unSmall l + res = filterEquals i li + s = fromList [Equals] + +-- RUNNER + spec :: Spec spec = do describe "gaps tests" $ @@ -472,7 +499,7 @@ it "filterMetBy property" $ property (prop_filterMetBy @Int) it "filterDuring property" $ property (prop_filterDuring @Int) it "filterContains property" $ property (prop_filterContains @Int) - it "filterEquals property" $ property (prop_filterEquals @Int) + it "filterEquals property" $ property prop_small_filterEquals it "filterDisjoint property" $ property (prop_filterDisjoint @Int) it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int) it "filterWithin property" $ property (prop_filterWithin @Int)