interval-algebra-2.2.0: test/IntervalAlgebraSpec.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module IntervalAlgebraSpec
( spec
) where
import Control.Applicative (liftA2)
import Data.Either (isRight)
import Data.Fixed (Pico)
import Data.Maybe (fromJust, isJust, isNothing)
import Data.Set (Set, disjointUnion, fromList,
member)
import Data.Time as DT (Day (..), DiffTime,
NominalDiffTime, UTCTime (..),
fromGregorian,
picosecondsToDiffTime,
secondsToDiffTime)
import GHC.Real (Rational (..), Real (..))
import IntervalAlgebra as IA
import IntervalAlgebra.Arbitrary (genDay)
import Test.Hspec (Spec, describe, hspec, it, shouldBe)
import Test.Hspec.QuickCheck (modifyMaxDiscardRatio,
modifyMaxSuccess)
import Test.QuickCheck (Arbitrary (arbitrary), Gen (..),
Property, Testable (property),
forAll, generate, quickCheck,
(.&&.), (===), (==>))
-- Convenience aliases
interval :: (iv ~ Interval a, SizedIv iv, Ord a, Ord (Moment iv)) => a -> a -> iv
interval = curry safeInterval
mkIntrvl :: Int -> Int -> Interval Int
mkIntrvl = beginerval
prop_expandl_end
:: (SizedIv (Interval a), Show a, Eq a) => Moment (Interval a) -> Interval a -> Property
prop_expandl_end d i = end (expandl d i) === end i
prop_expandr_begin
:: (SizedIv (Interval a), Show a, Eq a) => Moment (Interval a) -> Interval a -> Property
prop_expandr_begin d i = begin (expandr d i) === begin i
-- | The relation between x and z should be an element of the set of the
-- composed relations between x y and between y z.
prop_compose :: (Ord a, SizedIv (Interval a)) => Interval a -> Interval a -> Interval a -> Property
prop_compose x y z =
member (relate x z) (compose (relate x y) (relate y z)) === True
-- | If two intervals are disjoint and not meeting, then there should be a gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_gap_exists :: (Ord a, SizedIv (Interval a), Ord (Moment (Interval a))) => Interval a -> Interval a -> Property
prop_combinable_gap_exists x y =
(before <|> after) x y ==> isJust ((><) (min x y) (max x y))
-- | If two intervals are not disjoint or meeting, then there should be NO gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_nogap_exists :: (Ord a, SizedIv (Interval a), Ord (Moment (Interval a))) => Interval a -> Interval a -> Property
prop_combinable_nogap_exists x y =
(predicate $ complement $ fromList [Before, After]) x y
==> isNothing ((><) (min x y) (max x y))
{- Properties of SizedIv -}
-- When @Point iv@ is @Ord@,
--
-- prop> ivBegin i < ivEnd i
prop_validIv :: forall a. (SizedIv (Interval a), Ord a, Show a, Ord (Moment (Interval a))) => a -> a -> Property
prop_validIv b e = (ivBegin i < ivEnd i) === True where i = safeInterval (b, e)
-- When @iv@ is @Eq@,
--
-- prop> interval (ivBegin i) (ivEnd i) == i
prop_validIv' :: forall a. (SizedIv (Interval a), Ord a, Show a, Ord (Moment (Interval a))) => a -> a -> Property
prop_validIv' b e = interval (ivBegin i) (ivEnd i) === i where i = interval b e
-- When @iv@ is @Ord@, for all @i == interval b e@,
--
-- prop> ivExpandr d i >= i
-- prop> ivExpandl d i <= i
prop_ivExpandr, prop_ivExpandl :: forall a. (SizedIv (Interval a), Ord (Interval a), Show (Interval a)) => Moment (Interval a) -> Interval a -> Property
prop_ivExpandr d i = (ivExpandr d i >= i) === True
prop_ivExpandl d i = (ivExpandl d i <= i) === True
-- When @Moment iv@ is @Ord@,
--
-- prop> duration (interval b e) >= moment
-- prop> duration (ivExpandr d i) >= duration i
-- prop> duration (ivExpandl d i) >= duration i
prop_duration :: forall a. (SizedIv (Interval a), Ord a, Ord (Moment (Interval a)), Show (Interval a)) => Moment (Interval a) -> a -> a -> Property
prop_duration d b e = p1 .&&. p2 .&&. p3
where i = interval b e
m = moment @(Interval a)
dur = duration i
p1 = (dur >= m) === True
p2 = (duration (ivExpandr d i) >= dur) === True
p3 = (duration (ivExpandl d i) >= dur) === True
{- Specs -}
spec :: Spec
spec = do
describe "Basic Interval unit tests of typeclass and creation methods" $ do
it "equality works"
$ beginerval 6 (1 :: Int)
== beginerval 6 1
`shouldBe` True
it "equality works"
$ beginerval 0 (1 :: Int)
== beginerval (-1) 1
`shouldBe` True
it "equality works"
$ enderval 1 (2 :: Int)
== beginerval 1 1
`shouldBe` True
it "not equality works"
$ enderval 5 (2 :: Int)
/= beginerval 1 1
`shouldBe` True
it "beginervalMoment duration is moment"
$ duration (beginervalMoment (-13 :: Int))
`shouldBe` (moment @(Interval Int))
it "endervalMoment duration is moment"
$ duration (endervalMoment (26 :: Int))
`shouldBe` (moment @(Interval Int))
it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left
(IA.ParseErrorInterval "0<=10")
it "parsing fails on bad inputs" $ parseInterval 0 0 `shouldBe` Left
(IA.ParseErrorInterval "0<=0")
it "parsing works on good inputs" $ parseInterval 0 10 `shouldBe` Right
(beginerval 10 (0 :: Int))
it "show displays intervals as expected"
$ show (beginerval 10 (0 :: Int))
`shouldBe` "(0, 10)"
-- NOTE toEnum (fromGregorian 1858 11 17) is 0,
-- since that date is the origin in the modified
-- Julian calendar.
it "fromEnumInterval converts Interval Day"
$ fromEnumInterval (beginerval 0 (fromGregorian 1858 11 17))
`shouldBe` beginerval 0 0
it "(0, 2) <= (1, 3) is True"
$ beginerval 2 (0 :: Int)
<= beginerval 2 1
`shouldBe` True
it "(1, 2) < (0, 3) is True"
$ beginerval 2 (1 :: Int)
< beginerval 3 0
`shouldBe` False
it "(0, 2) < (1, 3) is True"
$ beginerval 2 (0 :: Int)
< beginerval 2 1
`shouldBe` True
it "(0, 2) < (0, 3) is True"
$ beginerval 2 (0 :: Int)
< beginerval 3 0
`shouldBe` True
describe "Basic IntervalRelation unit tests" $ do
it "equality of IntervalRelations" $ Before == Before `shouldBe` True
it "equality of IntervalRelations" $ Before /= After `shouldBe` True
it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before
it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After
it "show Before is Before" $ show Before `shouldBe` "Before"
describe "Relate unit tests" $ do
it "relate before"
$ relate (beginerval 1 (0 :: Int)) (beginerval 1 2)
`shouldBe` Before
it "relate after"
$ relate (beginerval 1 (2 :: Int)) (beginerval 1 0)
`shouldBe` After
it "relate meets"
$ relate (beginerval 1 (0 :: Int)) (beginerval 1 1)
`shouldBe` Meets
it "relate metBy"
$ relate (beginerval 1 (1 :: Int)) (beginerval 1 0)
`shouldBe` MetBy
it "relate overlaps"
$ relate (beginerval 3 (0 :: Int)) (beginerval 5 2)
`shouldBe` Overlaps
it "relate overlappedBy"
$ relate (beginerval 5 (2 :: Int)) (beginerval 3 0)
`shouldBe` OverlappedBy
it "relate starts"
$ relate (beginerval 3 (0 :: Int)) (beginerval 5 0)
`shouldBe` Starts
it "relate startedBy"
$ relate (beginerval 5 (0 :: Int)) (beginerval 3 0)
`shouldBe` StartedBy
it "relate finishes"
$ relate (enderval 3 (0 :: Int)) (enderval 5 0)
`shouldBe` Finishes
it "relate finishedBy"
$ relate (enderval 5 (0 :: Int)) (enderval 3 0)
`shouldBe` FinishedBy
it "relate during"
$ relate (beginerval 1 (1 :: Int)) (beginerval 3 0)
`shouldBe` During
it "relate Contains"
$ relate (beginerval 3 (0 :: Int)) (beginerval 1 1)
`shouldBe` Contains
describe "IntervalRelation algebraic operations" $ do
it "converse of Before is After"
$ converse (fromList [Before])
`shouldBe` fromList [After]
it "union of IntervalRelations"
$ union (fromList [Before]) (fromList [After])
`shouldBe` fromList [Before, After]
it "intersection of IntervalRelations"
$ intersection (fromList [Before]) (fromList [After])
`shouldBe` fromList []
describe "SizedIv tests" $ do
it "moment is 1" $ moment @(Interval Int) `shouldBe` 1
it "expandl doesn't change end" $ property (prop_expandl_end @Int)
it "expandr doesn't change begin" $ property (prop_expandr_begin @Int)
it "expand 0 5 Interval (0, 1) should be Interval (0, 6)"
$ expand 0 5 (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (6 :: Int) (0 :: Int)
it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)"
$ expand 5 0 (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (6 :: Int) (-5 :: Int)
it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)"
$ expand 5 5 (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (11 :: Int) (-5 :: Int)
it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)"
$ expand (-1) 5 (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (6 :: Int) (0 :: Int)
it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)"
$ expand 5 (-5) (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (6 :: Int) (-5 :: Int)
it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)"
$ expand (moment @(Interval Int)) 0 (beginerval (1 :: Int) (0 :: Int))
`shouldBe` beginerval (2 :: Int) (-1 :: Int)
it "beginerval 2 10 should be Interval (10, 12)"
$ Right (beginerval (2 :: Int) 10)
`shouldBe` parseInterval (10 :: Int) (12 :: Int)
it "beginerval 0 10 should be Interval (10, 11)"
$ Right (beginerval (0 :: Int) 10)
`shouldBe` parseInterval (10 :: Int) (11 :: Int)
it "beginerval -2 10 should be Interval (10, 11)"
$ Right (beginerval (-2 :: Int) 10)
`shouldBe` parseInterval (10 :: Int) (11 :: Int)
it "enderval 2 10 should be Interval (8, 10)"
$ Right (enderval (2 :: Int) 10)
`shouldBe` parseInterval (8 :: Int) (10 :: Int)
it "enderval 0 10 should be Interval (9, 10)"
$ Right (enderval (0 :: Int) 10)
`shouldBe` parseInterval (9 :: Int) (10 :: Int)
it "enderval -2 10 should be Interval (9, 10)"
$ Right (enderval (-2 :: Int) 10)
`shouldBe` parseInterval (9 :: Int) (10 :: Int)
it "shiftFromBegin can convert Interval Int to Interval Int"
$ shiftFromBegin (beginerval 2 (4 :: Int)) (beginerval 2 10)
`shouldBe` beginerval 2 6 -- (6, 8)
it "shiftFromEnd can convert Interval Int to Interval Int"
$ shiftFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10)
`shouldBe` beginerval 2 4 -- (4, 6)
it "momentize works"
$ momentize (beginerval 2 (fromGregorian 2001 1 1))
`shouldBe` beginerval 1 (fromGregorian 2001 1 1)
describe "SizedIv properties for Interval Int" $ do
it "validIv" $ property (prop_validIv @Int)
it "validIv'" $ property (prop_validIv' @Int)
it "ivExpandr" $ property (prop_ivExpandr @Int)
it "ivExpandl" $ property (prop_ivExpandl @Int)
it "duration" $ property (prop_duration @Int)
describe "SizedIv properties for Interval Day" $ do
it "validIv" $ forAll (liftA2 (,) genDay genDay) (uncurry prop_validIv)
it "validIv'" $ forAll (liftA2 (,) genDay genDay) (uncurry prop_validIv')
it "ivExpandr" $ property (prop_ivExpandr @Day)
it "ivExpandl" $ property (prop_ivExpandl @Day)
it "duration" $ forAll (do
m <- arbitrary
b <- genDay
e <- genDay
pure (m, b, e)
) (\(m, b, e) -> prop_duration m b e)
describe "Intervallic tests" $
-- modifyMaxSuccess (*10000) $
do
it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True"
$ (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1))
`shouldBe` True
it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True"
$ (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0)
`shouldBe` True
it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False"
$ (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1))
`shouldBe` False
it "disjoint x y same as explicit union of predicates"
$ disjoint (mkIntrvl 2 0) (mkIntrvl 2 3)
`shouldBe` (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0)
(mkIntrvl 2 3)
it "within x y same as explicit union of predicates"
$ within (mkIntrvl 2 3) (mkIntrvl 2 3)
`shouldBe` (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3)
(mkIntrvl 2 3)
it "prop_compose holds" $ property (prop_compose @Int)
describe "(.+.) tests" $ do
it "join non-meeting intervals is Nothing"
$ beginerval 2 (0 :: Int)
.+. beginerval 6 5
`shouldBe` Nothing
it "join meeting intervals is Just _"
$ beginerval 2 (0 :: Int)
.+. beginerval 6 2
`shouldBe` Just (beginerval 8 0)
it "gap of disjoint intervals should be something"
$ property (prop_combinable_gap_exists @Int)
it "gap of disjoint intervals should be something"
$ property (prop_combinable_gap_exists @Day)
it "gap of disjoint intervals should be something"
$ property (prop_combinable_gap_exists @UTCTime)
it "gap of nondisjoint, nonmeeting intervals should be nothing"
$ property (prop_combinable_nogap_exists @Int)
it "gap of nondisjoint, nonmeeting intervals should be nothing"
$ property (prop_combinable_nogap_exists @Day)
describe "Interval Algebra relation unit tests for synonyms" $ do
it "(0, 2) precedes (10, 12)"
$ beginerval 2 (0 :: Int)
`precedes` beginerval 2 10
`shouldBe` True
it "precedes matches before"
$ beginerval 10 (0 :: Int)
`precedes` beginerval 1 11
`shouldBe` beginerval 10 (0 :: Int)
`before` beginerval 1 11
it "(10, 12) precededBy (0, 2)"
$ precededBy (beginerval 2 10) (beginerval 2 (0 :: Int))
`shouldBe` True
it "precededBy matches after"
$ precededBy (beginerval 1 11) (beginerval 10 (0 :: Int))
`shouldBe` after (beginerval 1 11) (beginerval 10 (0 :: Int))
it "concur matches notDdisjoint"
$ concur (beginerval 1 11) (beginerval 10 (0 :: Int))
`shouldBe` notDisjoint (beginerval 1 11) (beginerval 10 (0 :: Int))
it "concur matches notDisjoint"
$ concur (beginerval 1 0) (beginerval 10 (0 :: Int))
`shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int))