interval-algebra 1.3.0 → 1.4.0

raw patch · 18 files changed

+2684/−1597 lines, 18 filesdep +nonempty-containersdep +prettyprinterdep +textdep ~QuickCheckdep ~binarydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: nonempty-containers, prettyprinter, text, witch

Dependency ranges changed: QuickCheck, binary, containers, deepseq, foldl, hspec, safe, time, witherable

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• interval-algebra.cabal +31/−24
• src/IntervalAlgebra.hs +8/−8
• src/IntervalAlgebra/Arbitrary.hs +69/−35
• src/IntervalAlgebra/Axioms.hs +53/−42
• src/IntervalAlgebra/Core.hs +425/−314
• src/IntervalAlgebra/IntervalDiagram.hs +725/−0
• src/IntervalAlgebra/IntervalUtilities.hs +368/−322
• src/IntervalAlgebra/PairedInterval.hs +40/−39
• src/IntervalAlgebra/RelationProperties.hs +67/−58
• test-axioms/AxiomsSpec.hs +50/−38
• test-axioms/Main.hs +2/−2
• test-relation-properties/Main.hs +2/−2
• test-relation-properties/RelationPropertiesSpec.hs +66/−58
• test/IntervalAlgebra/IntervalUtilitiesSpec.hs +423/−370
• test/IntervalAlgebra/PairedIntervalSpec.hs +61/−55
• test/IntervalAlgebraSpec.hs +282/−230
• test/Spec.hs +0/−0

@@ -1,5 +1,17 @@ # Changelog for interval-algebra +## 1.4.0++* Adds the `safeInterval` function to `Core`,+as a utility for creating intervals from a pair of endpoints.+* Uses+[PVP](https://pvp.haskell.org/)-style+major upper bounds in cabal dependencies as described+[here](https://cabal.readthedocs.io/en/3.4/cabal-package.html#build-information).+* Adds the `IntervalDiagram` module which includes functions and types+for printing diagrams of intervals as text.+These functions are useful for documentation and examples.+ ## 1.3.0  * Adds `NFData` and `Binary` instances for `Interval` and `PairedInterval`

@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           interval-algebra-version:        1.3.0+version:        1.4.0 synopsis:       An implementation of Allen's interval algebra for temporal logic description:    Please see the README on GitHub at <https://github.com/novisci/interval-algebra> category:       Algebra,Time@@ -25,6 +25,7 @@       IntervalAlgebra       IntervalAlgebra.Core       IntervalAlgebra.IntervalUtilities+      IntervalAlgebra.IntervalDiagram       IntervalAlgebra.PairedInterval       IntervalAlgebra.Axioms       IntervalAlgebra.RelationProperties@@ -37,14 +38,18 @@       src   build-depends:       base >=4.7 && <5-    , binary-    , deepseq-    , time >=1.8 && <2-    , foldl == 1.4.12-    , containers >= 0.6-    , witherable >= 0.4-    , safe >= 0.3-    , QuickCheck == 2.14.2+    , binary ^>= 0.8+    , containers ^>= 0.6+    , deepseq ^>= 1.4+    , foldl ^>= 1.4.12+    , nonempty-containers ^>= 0.3.4+    , prettyprinter ^>= 1.7+    , QuickCheck ^>= 2.14.2+    , safe ^>= 0.3+    , text ^>= 1.2+    , time ^>= 1.9+    , witch ^>= 1.0+    , witherable ^>= 0.4.2   default-language: Haskell2010  test-suite axioms@@ -56,11 +61,11 @@       test-axioms   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      QuickCheck == 2.14.2-    , base >=4.7 && <5-    , hspec == 2.8.2+      base >=4.7 && <5+    , hspec ^>= 2.8.2     , interval-algebra-    , time >=1.8 && <2+    , QuickCheck ^>= 2.14.2+    , time ^>= 1.9   default-language: Haskell2010  test-suite relations@@ -72,11 +77,11 @@       test-relation-properties   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      QuickCheck == 2.14.2-    , base >=4.7 && <5-    , hspec == 2.8.2+      base >=4.7 && <5+    , hspec ^>= 2.8.2     , interval-algebra-    , time >=1.8 && <2+    , QuickCheck ^>= 2.14.2+    , time ^>= 1.9   default-language: Haskell2010  test-suite interval-algebra-test@@ -93,12 +98,14 @@       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      QuickCheck == 2.14.2-    , base >=4.7 && <5-    , hspec == 2.8.2-    , containers >= 0.6+      base >=4.7 && <5+    , containers ^>= 0.6+    , hspec ^>= 2.8.2     , interval-algebra-    , time >=1.8 && <2-    , witherable >= 0.4-    , safe >= 0.3+    , QuickCheck ^>= 2.14.2+    , safe ^>= 0.3+    , time ^>= 1.9+    , witherable ^>= 0.4.2+  build-tool-depends:+      hspec-discover:hspec-discover >= 2.9.2   default-language: Haskell2010

@@ -17,12 +17,12 @@ -}  {-# LANGUAGE Safe #-}-module IntervalAlgebra( -      module IntervalAlgebra.Core-    , module IntervalAlgebra.IntervalUtilities-    , module IntervalAlgebra.PairedInterval-) where+module IntervalAlgebra+  ( module IntervalAlgebra.Core+  , module IntervalAlgebra.IntervalUtilities+  , module IntervalAlgebra.PairedInterval+  ) where -import safe IntervalAlgebra.Core -import safe IntervalAlgebra.IntervalUtilities -import safe IntervalAlgebra.PairedInterval +import safe      IntervalAlgebra.Core+import safe      IntervalAlgebra.IntervalUtilities+import safe      IntervalAlgebra.PairedInterval

@@ -12,35 +12,66 @@ {-# LANGUAGE FlexibleContexts #-}  -module IntervalAlgebra.Arbitrary( arbitraryWithRelation ) where+module IntervalAlgebra.Arbitrary+  ( arbitraryWithRelation+  ) where -import           Control.Applicative (liftA2, (<$>))-import           Control.Monad       (liftM2)+import           Control.Applicative            ( (<$>)+                                                , liftA2+                                                )+import           Control.Monad                  ( liftM2 ) import           Data.Bool import           Data.Fixed-import           Data.Function       (flip, ($), (.))-import           Data.Maybe          (Maybe (Just, Nothing))+import           Data.Function                  ( ($)+                                                , (.)+                                                , flip+                                                )+import           Data.Maybe                     ( Maybe(Just, Nothing) ) import           Data.Ord-import qualified Data.Set            (Set, difference, null, singleton)-import           Data.Time           as DT (Day (ModifiedJulianDay), DiffTime,-                                            NominalDiffTime, UTCTime (..),-                                            picosecondsToDiffTime,-                                            secondsToDiffTime,-                                            secondsToNominalDiffTime,-                                            toModifiedJulianDay)+import qualified Data.Set                       ( Set+                                                , difference+                                                , null+                                                , singleton+                                                )+import           Data.Time                     as DT+                                                ( Day(ModifiedJulianDay)+                                                , DiffTime+                                                , NominalDiffTime+                                                , UTCTime(..)+                                                , picosecondsToDiffTime+                                                , secondsToDiffTime+                                                , secondsToNominalDiffTime+                                                , toModifiedJulianDay+                                                ) import           GHC.Float-import           GHC.Int             (Int)+import           GHC.Int                        ( Int ) import           GHC.Num import           GHC.Real-import           IntervalAlgebra     (Interval, IntervalRelation (..),-                                      PairedInterval, makePairedInterval,-                                      IntervalSizeable, Intervallic, beginerval,-                                      converse, duration, moment', predicate,-                                      strictWithinRelations)-import           Prelude             (Eq, (==))-import           Test.QuickCheck     (Arbitrary (arbitrary, shrink), Gen,-                                      NonNegative, arbitrarySizedNatural,-                                      elements, resize, suchThat, sized)+import           IntervalAlgebra                ( Interval+                                                , IntervalRelation(..)+                                                , IntervalSizeable+                                                , Intervallic+                                                , PairedInterval+                                                , beginerval+                                                , converse+                                                , duration+                                                , makePairedInterval+                                                , moment'+                                                , predicate+                                                , strictWithinRelations+                                                )+import           Prelude                        ( (==)+                                                , Eq+                                                )+import           Test.QuickCheck                ( Arbitrary(arbitrary, shrink)+                                                , Gen+                                                , NonNegative+                                                , arbitrarySizedNatural+                                                , elements+                                                , resize+                                                , sized+                                                , suchThat+                                                )  -- NOTE: the default size for arbitrary :: Gen Int appears to be 30 arbitrarySizedPositive :: Integral a => Gen a@@ -55,18 +86,20 @@   arbitrary = liftM2 beginerval arbitrarySizedPositive arbitrary  instance Arbitrary DT.Day where-    arbitrary = sized (\s -> DT.ModifiedJulianDay <$> s `resize` arbitrary)-    shrink    = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay+  arbitrary = sized (\s -> DT.ModifiedJulianDay <$> s `resize` arbitrary)+  shrink    = (DT.ModifiedJulianDay <$>) . shrink . DT.toModifiedJulianDay  instance Arbitrary DT.NominalDiffTime where-   arbitrary = sized (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))+  arbitrary = sized+    (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))  instance Arbitrary DT.DiffTime where-   arbitrary = sized (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))+  arbitrary = sized+    (\s -> fromInteger <$> (min s maxDiffTime `resize` arbitrarySizedNatural))  instance Arbitrary DT.UTCTime  where-    arbitrary = liftA2 UTCTime arbitrary arbitrary-                  +  arbitrary = liftA2 UTCTime arbitrary arbitrary+ instance Arbitrary (Interval DT.Day) where   arbitrary = liftM2 beginerval arbitrary arbitrary @@ -74,7 +107,7 @@   arbitrary = liftM2 beginerval arbitrary arbitrary  instance (Arbitrary b, Arbitrary (Interval a)) => Arbitrary (PairedInterval b a) where-  arbitrary = liftM2 makePairedInterval arbitrary arbitrary +  arbitrary = liftM2 makePairedInterval arbitrary arbitrary  -- | Conditional generation of intervals relative to a reference.  If the -- reference `iv` is of 'moment' duration, it is not possible to generate@@ -90,8 +123,9 @@ -- Nothing -- >>> generate $ arbitraryWithRelation (beginerval 1 (0::Int)) (fromList [StartedBy, Before]) -- Just (4, 13)-arbitraryWithRelation :: (IntervalSizeable a b, Intervallic i a, Arbitrary (i a)) => -  i a -- ^ reference interval+arbitraryWithRelation+  :: (IntervalSizeable a b, Intervallic i a, Arbitrary (i a))+  => i a -- ^ reference interval   -> Data.Set.Set IntervalRelation -- ^ set of `IntervalRelation`s, of which at least one will hold for the generated interval relative to the reference   -> Gen (Maybe (i a)) arbitraryWithRelation iv rs@@ -99,7 +133,7 @@   | isEnclose && isMom = elements [Nothing]   | isMom = Just <$> arbitrary `suchThat` predicate notStrictEnclose iv   | otherwise = Just <$> arbitrary `suchThat` predicate rs iv-  where-    notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations)-    isEnclose = Data.Set.null notStrictEnclose-    isMom = duration iv == moment' iv+ where+  notStrictEnclose = Data.Set.difference rs (converse strictWithinRelations)+  isEnclose        = Data.Set.null notStrictEnclose+  isMom            = duration iv == moment' iv

@@ -1,3 +1,4 @@+{- HLINT ignore -} {-| Module      : Interval Algebra Axioms Description : Properties of Intervals@@ -15,49 +16,57 @@  {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-module IntervalAlgebra.Axioms (-   IntervalAxioms(..)-   , M1set(..)-   , M2set(..)-   , M5set(..)-) where -import Test.QuickCheck            ( (===)-                                  , (==>)-                                  , Property-                                  , Arbitrary (arbitrary) )-import Data.Either                ( isRight )-import Data.Maybe                 ( fromJust, isJust, isNothing )-import Data.Time as DT            ( Day(..)-                                  , UTCTime(..)-                                  , DiffTime-                                  , NominalDiffTime-                                  )-import Data.Set                   ( Set-                                  , member-                                  , disjointUnion-                                  , fromList )-import IntervalAlgebra.Core-import IntervalAlgebra.Arbitrary +module IntervalAlgebra.Axioms+  ( IntervalAxioms(..)+  , M1set(..)+  , M2set(..)+  , M5set(..)+  ) where +import           Data.Either                    ( isRight )+import           Data.Maybe                     ( fromJust+                                                , isJust+                                                , isNothing+                                                )+import           Data.Set                       ( Set+                                                , disjointUnion+                                                , fromList+                                                , member+                                                )+import           Data.Time                     as DT+                                                ( Day(..)+                                                , DiffTime+                                                , NominalDiffTime+                                                , UTCTime(..)+                                                )+import           IntervalAlgebra.Arbitrary+import           IntervalAlgebra.Core+import           Test.QuickCheck                ( (===)+                                                , (==>)+                                                , Arbitrary(arbitrary)+                                                , Property+                                                )++ xor :: Bool -> Bool -> Bool xor a b = a /= b  -- | Internal function for converting a number to a strictly positive value. makePos :: (Ord b, Num b) => b -> b-makePos x-  | x == 0    = x + 1-  | x <  0    = negate x-  | otherwise = x+makePos x | x == 0    = x + 1+          | x < 0     = negate x+          | otherwise = x  -- | A set used for testing M1 defined so that the M1 condition is true.-data M1set a = M1set {-     m11 :: Interval a-   , m12 :: Interval a-   , m13 :: Interval a-   , m14 :: Interval a }-   deriving (Show)+data M1set a = M1set+  { m11 :: Interval a+  , m12 :: Interval a+  , m13 :: Interval a+  , m14 :: Interval a+  }+  deriving Show  instance Arbitrary (M1set Int) where   arbitrary = do@@ -82,12 +91,13 @@   -- | A set used for testing M2 defined so that the M2 condition is true.-data M2set a = M2set {-    m21 :: Interval a+data M2set a = M2set+  { m21 :: Interval a   , m22 :: Interval a   , m23 :: Interval a-  , m24 :: Interval a }-  deriving (Show)+  , m24 :: Interval a+  }+  deriving Show  instance Arbitrary (M2set Int) where   arbitrary = do@@ -111,10 +121,11 @@     m2set x a b <$> arbitrary  -- | A set used for testing M5.-data M5set a = M5set {-     m51 :: Interval a-   , m52 :: Interval a }-   deriving (Show)+data M5set a = M5set+  { m51 :: Interval a+  , m52 :: Interval a+  }+  deriving Show  instance Arbitrary (M5set Int) where   arbitrary = do@@ -339,4 +350,4 @@  instance IntervalAxioms Int Int instance IntervalAxioms Day Integer-instance IntervalAxioms UTCTime NominalDiffTime +instance IntervalAxioms UTCTime NominalDiffTime

@@ -33,29 +33,35 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} -module IntervalAlgebra.Core(+module IntervalAlgebra.Core+  (      -- * Intervals-      Interval-    , Intervallic(..)-    , ParseErrorInterval(..)-    , begin-    , end+    Interval+  , Intervallic(..)+  , ParseErrorInterval(..)+  , begin+  , end      -- ** Create new intervals-    , parseInterval-    , beginerval-    , enderval+  , parseInterval+  , prsi+  , beginerval+  , bi+  , enderval+  , ei+  , safeInterval+  , si      -- ** Modify intervals  -    , expand-    , expandl-    , expandr+  , expand+  , expandl+  , expandr      -- * Interval Algebra       -- ** Interval Relations and Predicates-    , IntervalRelation(..)+  , IntervalRelation(..)      {- |     === Meets, Metby@@ -68,7 +74,8 @@     y:       |-----|      @     -}-    , meets      , metBy+  , meets+  , metBy      {- |     === Before, After@@ -81,7 +88,8 @@     y:          |-----|     @     -}-    , before     , after+  , before+  , after      {- |     === Overlaps, OverlappedBy@@ -94,7 +102,8 @@     y:     |-----|     @     -}-    , overlaps   , overlappedBy+  , overlaps+  , overlappedBy      {- |     === Finishes, FinishedBy@@ -107,7 +116,8 @@     y: |-----|     @     -}-    , finishedBy , finishes+  , finishedBy+  , finishes      {- |     === During, Contains@@ -120,7 +130,8 @@     y: |-----|     @     -}-    , contains   , during+  , contains+  , during      {- |     === Starts, StartedBy@@ -133,7 +144,8 @@     y: |-----|     @     -}-    , starts     , startedBy+  , starts+  , startedBy      {- |     === Equal@@ -146,82 +158,121 @@     y: |-----|     @     -}-    , equals+  , equals      -- ** Additional predicates and utilities-    , precedes, precededBy-    , disjoint , notDisjoint, concur-    , within, enclose, enclosedBy-    , (<|>)-    , predicate, unionPredicates-    , disjointRelations, withinRelations-    , strictWithinRelations-    , ComparativePredicateOf1-    , ComparativePredicateOf2-    , beginervalFromEnd-    , endervalFromBegin-    , beginervalMoment-    , endervalMoment-    , diffFromBegin-    , diffFromEnd-    , momentize+  , precedes+  , precededBy+  , disjoint+  , notDisjoint+  , concur+  , within+  , enclose+  , enclosedBy+  , (<|>)+  , predicate+  , unionPredicates+  , disjointRelations+  , withinRelations+  , strictWithinRelations+  , ComparativePredicateOf1+  , ComparativePredicateOf2+  , beginervalFromEnd+  , endervalFromBegin+  , beginervalMoment+  , endervalMoment+  , diffFromBegin+  , diffFromEnd+  , momentize      -- ** Algebraic operations-    , intervalRelations-    , relate-    , compose-    , complement-    , union-    , intersection-    , converse+  , intervalRelations+  , relate+  , compose+  , complement+  , union+  , intersection+  , converse      -- * Combine two intervals-    , IntervalCombinable(..)-    , extenterval+  , IntervalCombinable(..)+  , extenterval      -- * Measure an interval-    , IntervalSizeable(..)--) where+  , IntervalSizeable(..)+  ) where -import Prelude                  ( Eq, Show, Enum(..), Bounded(..)-                                , Maybe(..), Either(..), String, Bool(..)-                                , Integer, Int, Num, Rational-                                , map, otherwise, show-                                , any, negate, not-                                , replicate-                                , fromRational-                                , toRational-                                , fromInteger-                                , toInteger-                                , (++), (==), (&&), (+), (-), (!!), realToFrac)-import Data.Function            ( ($), id, (.), flip )-import Data.Functor             ( Functor(fmap) )-import GHC.Generics             ( Generic )-import Data.Ord                 ( Ord(..), Ordering(..), min, max )-import Data.Semigroup           ( Semigroup((<>)) )-import qualified Data.Set       ( Set-                                , fromList-                                , difference-                                , intersection-                                , union-                                , map-                                , toList )-import Data.Tuple               ( fst, snd )-import Data.Fixed               ( Pico )-import Data.Time as DT          ( Day-                                , UTCTime-                                , NominalDiffTime-                                , DiffTime-                                , addUTCTime-                                , diffUTCTime-                                , secondsToNominalDiffTime-                                , nominalDiffTimeToSeconds-                                , addDays-                                , diffDays )-import Control.Applicative      ( Applicative(pure) )-import Data.Binary              ( Binary )-import Control.DeepSeq          ( NFData )+import           Control.Applicative            ( Applicative(pure) )+import           Control.DeepSeq                ( NFData )+import           Data.Binary                    ( Binary )+import           Data.Fixed                     ( Pico )+import           Data.Function                  ( ($)+                                                , (.)+                                                , flip+                                                , id+                                                )+import           Data.Functor                   ( Functor(fmap) )+import           Data.Ord                       ( Ord(..)+                                                , Ordering(..)+                                                , max+                                                , min+                                                )+import           Data.Semigroup                 ( Semigroup((<>)) )+import qualified Data.Set                       ( Set+                                                , difference+                                                , fromList+                                                , intersection+                                                , map+                                                , toList+                                                , union+                                                )+import           Data.Time                     as DT+                                                ( Day+                                                , DiffTime+                                                , NominalDiffTime+                                                , UTCTime+                                                , addDays+                                                , addUTCTime+                                                , diffDays+                                                , diffUTCTime+                                                , nominalDiffTimeToSeconds+                                                , secondsToNominalDiffTime+                                                )+import           Data.Tuple                     ( fst+                                                , snd+                                                )+import           GHC.Generics                   ( Generic )+import           Prelude                        ( (!!)+                                                , (&&)+                                                , (+)+                                                , (++)+                                                , (-)+                                                , (==)+                                                , Bool(..)+                                                , Bounded(..)+                                                , Either(..)+                                                , Enum(..)+                                                , Eq+                                                , Int+                                                , Integer+                                                , Maybe(..)+                                                , Num+                                                , Rational+                                                , Show+                                                , String+                                                , any+                                                , fromInteger+                                                , fromRational+                                                , map+                                                , negate+                                                , not+                                                , otherwise+                                                , realToFrac+                                                , replicate+                                                , show+                                                , toInteger+                                                , toRational+                                                )  {- | An @'Interval' a@ is a pair \( (x, y) \text{ such that } x < y\). To create intervals use the @'parseInterval'@, @'beginerval'@, or @'enderval'@ functions.@@ -229,7 +280,7 @@ newtype Interval a = Interval (a, a) deriving (Eq, Generic)  -- | A type identifying interval parsing errors.-newtype ParseErrorInterval = ParseErrorInterval String +newtype ParseErrorInterval = ParseErrorInterval String     deriving (Eq, Show)  -- | Safely parse a pair of @a@s to create an @'Interval' a@.@@ -240,11 +291,16 @@ -- >>> parseInterval 1 0 -- Left "0<1" -- -parseInterval :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a)+parseInterval+  :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a) parseInterval x y-    | x < y     = Right $ Interval (x, y) -    | otherwise = Left  $ ParseErrorInterval $ show y ++ "<=" ++ show x+  | x < y     = Right $ Interval (x, y)+  | otherwise = Left $ ParseErrorInterval $ show y ++ "<=" ++ show x +-- | A synonym for `parseInterval`+prsi :: (Show a, Ord a) => a -> a -> Either ParseErrorInterval (Interval a)+prsi = parseInterval+ intervalBegin :: (Ord a) => Interval a -> a intervalBegin (Interval x) = fst x @@ -252,10 +308,10 @@ intervalEnd (Interval x) = snd x  instance Functor Interval where-    fmap f (Interval (x, y)) = Interval (f x, f y)+  fmap f (Interval (x, y)) = Interval (f x, f y)  instance (Show a, Ord a) => Show (Interval a) where-   show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")"+  show x = "(" ++ show (begin x) ++ ", " ++ show (end x) ++ ")"  instance Binary a => Binary (Interval a) instance NFData a => NFData (Interval a)@@ -285,7 +341,7 @@ -- | Access the endpoints of an @i a@ . begin, end :: Intervallic i a => i a -> a begin = intervalBegin . getInterval-end   = intervalEnd . getInterval+end = intervalEnd . getInterval  {- |  The 'IntervalRelation' type and the associated predicate functions enumerate@@ -310,59 +366,67 @@     deriving (Eq, Show, Enum)  instance Bounded IntervalRelation where-    minBound = Before-    maxBound = After+  minBound = Before+  maxBound = After  instance Ord IntervalRelation where-    compare x y = compare (fromEnum x) (fromEnum y)+  compare x y = compare (fromEnum x) (fromEnum y)  -- | Does x `meets` y? Is x metBy y?-meets, metBy  :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)+meets, metBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a) meets x y = end x == begin y-metBy     = flip meets+metBy = flip meets  -- | Is x before y? Is x after y?-before, after, precedes, precededBy  :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-before   x y  = end x < begin y-after         = flip before-precedes      = before-precededBy    = after+before, after, precedes, precededBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+before x y = end x < begin y+after = flip before+precedes = before+precededBy = after -- | Does x overlap y? Is x overlapped by y?-overlaps, overlappedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-overlaps x y  = begin x < begin y && end x < end y && end x > begin y-overlappedBy  = flip overlaps+overlaps, overlappedBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+overlaps x y = begin x < begin y && end x < end y && end x > begin y+overlappedBy = flip overlaps  -- | Does x start y? Is x started by y?-starts, startedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-starts   x y  = begin x == begin y && end x < end y-startedBy     = flip starts+starts, startedBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+starts x y = begin x == begin y && end x < end y+startedBy = flip starts  -- | Does x finish y? Is x finished by y?-finishes, finishedBy :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-finishes x y  = begin x > begin y && end x == end y-finishedBy    = flip finishes+finishes, finishedBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+finishes x y = begin x > begin y && end x == end y+finishedBy = flip finishes  -- | Is x during y? Does x contain y?-during, contains :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-during   x y  = begin x > begin y && end x < end y-contains      = flip during+during, contains+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+during x y = begin x > begin y && end x < end y+contains = flip during  -- | Does x equal y?-equals :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-equals   x y  = begin x == begin y && end x == end y+equals+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+equals x y = begin x == begin y && end x == end y  -- | Operator for composing the union of two predicates-(<|>) :: (Intervallic i0 a, Intervallic i1 a)=>-       ComparativePredicateOf2 (i0 a) (i1 a)-    -> ComparativePredicateOf2 (i0 a) (i1 a)-    -> ComparativePredicateOf2 (i0 a) (i1 a)+(<|>)+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+  -> ComparativePredicateOf2 (i0 a) (i1 a)+  -> ComparativePredicateOf2 (i0 a) (i1 a) (<|>) f g = unionPredicates [f, g]  -- | The set of @IntervalRelation@ meaning two intervals are disjoint.@@ -378,39 +442,44 @@ strictWithinRelations = Data.Set.difference withinRelations (toSet [Equals])  -- | Are x and y disjoint ('before', 'after', 'meets', or 'metBy')?-disjoint :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-disjoint    = predicate disjointRelations+disjoint+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+disjoint = predicate disjointRelations  -- | Are x and y not disjoint (concur); i.e. do they share any support? This is --   the 'complement' of 'disjoint'.-notDisjoint, concur :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)+notDisjoint, concur+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a) notDisjoint = predicate (complement disjointRelations)-concur      = notDisjoint+concur = notDisjoint  -- | Is x entirely *within* (enclosed by) the endpoints of y? That is, 'during',  --   'starts', 'finishes', or 'equals'?-within, enclosedBy:: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-within     = predicate withinRelations+within, enclosedBy+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+within = predicate withinRelations enclosedBy = within  -- | Does x enclose y? That is, is y 'within' x?-enclose :: (Intervallic i0 a, Intervallic i1 a)=>-    ComparativePredicateOf2 (i0 a) (i1 a)-enclose  = flip enclosedBy+enclose+  :: (Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+enclose = flip enclosedBy  -- | The 'Data.Set.Set' of all 'IntervalRelation's. intervalRelations :: Data.Set.Set IntervalRelation-intervalRelations = Data.Set.fromList (Prelude.map toEnum [0..12] ::[IntervalRelation])+intervalRelations =+  Data.Set.fromList (Prelude.map toEnum [0 .. 12] :: [IntervalRelation])  -- | Find the converse of a single 'IntervalRelation'-converseRelation :: IntervalRelation  -> IntervalRelation+converseRelation :: IntervalRelation -> IntervalRelation converseRelation x = toEnum (12 - fromEnum x)  -- | Shortcut to creating a 'Set IntervalRelation' from a list.-toSet :: [IntervalRelation ] -> Data.Set.Set IntervalRelation+toSet :: [IntervalRelation] -> Data.Set.Set IntervalRelation toSet = Data.Set.fromList  -- | Compose a list of interval relations with _or_ to create a new@@ -418,85 +487,88 @@ -- @unionPredicates [before, meets]@ creates a predicate function determining -- if one interval is either before or meets another interval. unionPredicates :: [ComparativePredicateOf2 a b] -> ComparativePredicateOf2 a b-unionPredicates fs x y = any (\ f -> f x y) fs+unionPredicates fs x y = any (\f -> f x y) fs  -- | Maps an 'IntervalRelation' to its corresponding predicate function.-toPredicate :: (Intervallic i0 a, Intervallic i1 a) =>-           IntervalRelation-        -> ComparativePredicateOf2 (i0 a) (i1 a)-toPredicate r =-    case r of-        Before       -> before-        Meets        -> meets-        Overlaps     -> overlaps-        FinishedBy   -> finishedBy-        Contains     -> contains-        Starts       -> starts-        Equals       -> equals-        StartedBy    -> startedBy-        During       -> during-        Finishes     -> finishes-        OverlappedBy -> overlappedBy-        MetBy        -> metBy-        After        -> after+toPredicate+  :: (Intervallic i0 a, Intervallic i1 a)+  => IntervalRelation+  -> ComparativePredicateOf2 (i0 a) (i1 a)+toPredicate r = case r of+  Before       -> before+  Meets        -> meets+  Overlaps     -> overlaps+  FinishedBy   -> finishedBy+  Contains     -> contains+  Starts       -> starts+  Equals       -> equals+  StartedBy    -> startedBy+  During       -> during+  Finishes     -> finishes+  OverlappedBy -> overlappedBy+  MetBy        -> metBy+  After        -> after  -- | Given a set of 'IntervalRelation's return a list of 'predicate' functions  --   corresponding to each relation.-predicates :: (Intervallic i0 a, Intervallic i1 a)=>-           Data.Set.Set IntervalRelation-        -> [ComparativePredicateOf2 (i0 a) (i1 a)]+predicates+  :: (Intervallic i0 a, Intervallic i1 a)+  => Data.Set.Set IntervalRelation+  -> [ComparativePredicateOf2 (i0 a) (i1 a)] predicates x = Prelude.map toPredicate (Data.Set.toList x)  -- | Forms a predicate function from the union of a set of 'IntervalRelation's.-predicate :: (Intervallic i0 a, Intervallic i1 a)=>-           Data.Set.Set IntervalRelation-        -> ComparativePredicateOf2 (i0 a) (i1 a)-predicate = unionPredicates.predicates+predicate+  :: (Intervallic i0 a, Intervallic i1 a)+  => Data.Set.Set IntervalRelation+  -> ComparativePredicateOf2 (i0 a) (i1 a)+predicate = unionPredicates . predicates  -- | The lookup table for the compositions of interval relations. composeRelationLookup :: [[[IntervalRelation]]] composeRelationLookup =-      [ [p    , p    , p    , p    , p    , p    , p , p    , pmosd, pmosd, pmosd, pmosd, full ]-      , [p    , p    , p    , p    , p    , m    , m , m    , osd  , osd  , osd  , fef  , dsomp]-      , [p    , p    , pmo  , pmo  , pmofd, o    , o , ofd  , osd  , osd  , cncr , dso  , dsomp]-      , [p    , m    , o    , f'   , d'   , o    , f', d'   , osd  , fef  , dso  , dso  , dsomp]-      , [pmofd, ofd  , ofd  , d'   , d'   , ofd  , d', d'   , cncr , dso  , dso  , dso  , dsomp]-      , [p    , p    , pmo  , pmo  , pmofd, s    , s , ses  , d    , d    , dfo  , m'   , p'   ]-      , [p    , m    , o    , f'   , d'   , s    , e , s'   , d    , f    , o'   , m'   , p'   ]-      , [pmofd, ofd  , ofd  , d'   , d'   , ses  , s', s'   , dfo  , o'   , o'   , m'   , p'   ]-      , [p    , p    , pmosd, pmosd, full , d    , d , dfomp, d    , d    , dfomp, p'   , p'   ]-      , [p    , m    , osd  , fef  , dsomp, d    , f , omp  , d    , f    , omp  , p'   , p'   ]-      , [pmofd, ofd  , cncr , dso  , dsomp, dfo  , o', omp  , dfo  , o'   , omp  , p'   , p'   ]-      , [pmofd, ses  , dfo  , m'   , p'   , dfo  , m', p'   , dfo  , m'   , p'   , p'   , p'   ]-      , [full , dfomp, dfomp, p'   , p'   , dfomp, p', p'   , dfomp, p'   , p'   , p'   , p'   ]-      ]-      where p  = [Before]-            m  = [Meets]-            o  = [Overlaps]-            f' = [FinishedBy]-            d' = [Contains]-            s  = [Starts]-            e  = [Equals]-            s' = [StartedBy]-            d  = [During]-            f  = [Finishes]-            o' = [OverlappedBy]-            m' = [MetBy]-            p' = [After]-            ses    = s ++ e ++ s'-            fef    = f' ++ e ++ f-            pmo    = p ++ m ++ o-            pmofd  = pmo ++ f' ++ d'-            osd    = o ++ s ++ d-            ofd    = o ++ f' ++ d'-            omp    = o' ++ m' ++ p'-            dfo    = d ++ f ++ o'-            dfomp  = dfo ++ m' ++ p'-            dso    = d' ++ s' ++ o'-            dsomp  = dso ++ m' ++ p'-            pmosd  = p ++ m ++ osd-            cncr = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o'-            full = p ++ m ++ cncr ++ m' ++ p'+  [ [p, p, p, p, p, p, p, p, pmosd, pmosd, pmosd, pmosd, full]+  , [p, p, p, p, p, m, m, m, osd, osd, osd, fef, dsomp]+  , [p, p, pmo, pmo, pmofd, o, o, ofd, osd, osd, cncr, dso, dsomp]+  , [p, m, o, f', d', o, f', d', osd, fef, dso, dso, dsomp]+  , [pmofd, ofd, ofd, d', d', ofd, d', d', cncr, dso, dso, dso, dsomp]+  , [p, p, pmo, pmo, pmofd, s, s, ses, d, d, dfo, m', p']+  , [p, m, o, f', d', s, e, s', d, f, o', m', p']+  , [pmofd, ofd, ofd, d', d', ses, s', s', dfo, o', o', m', p']+  , [p, p, pmosd, pmosd, full, d, d, dfomp, d, d, dfomp, p', p']+  , [p, m, osd, fef, dsomp, d, f, omp, d, f, omp, p', p']+  , [pmofd, ofd, cncr, dso, dsomp, dfo, o', omp, dfo, o', omp, p', p']+  , [pmofd, ses, dfo, m', p', dfo, m', p', dfo, m', p', p', p']+  , [full, dfomp, dfomp, p', p', dfomp, p', p', dfomp, p', p', p', p']+  ]+ where+  p     = [Before]+  m     = [Meets]+  o     = [Overlaps]+  f'    = [FinishedBy]+  d'    = [Contains]+  s     = [Starts]+  e     = [Equals]+  s'    = [StartedBy]+  d     = [During]+  f     = [Finishes]+  o'    = [OverlappedBy]+  m'    = [MetBy]+  p'    = [After]+  ses   = s ++ e ++ s'+  fef   = f' ++ e ++ f+  pmo   = p ++ m ++ o+  pmofd = pmo ++ f' ++ d'+  osd   = o ++ s ++ d+  ofd   = o ++ f' ++ d'+  omp   = o' ++ m' ++ p'+  dfo   = d ++ f ++ o'+  dfomp = dfo ++ m' ++ p'+  dso   = d' ++ s' ++ o'+  dsomp = dso ++ m' ++ p'+  pmosd = p ++ m ++ osd+  cncr  = o ++ f' ++ d' ++ s ++ e ++ s' ++ d ++ f ++ o'+  full  = p ++ m ++ cncr ++ m' ++ p'  -- | Compare two @i a@ to determine their 'IntervalRelation'. --@@ -506,27 +578,27 @@ -- >>> relate (Interval (1::Int, 2)) (Interval (0, 1)) -- MetBy -- -relate :: (Intervallic i0 a, Intervallic i1 a) => i0 a -> i1 a -> IntervalRelation-relate x y-    | x `before` y       = Before-    | x `after`  y       = After-    | x `meets`  y       = Meets-    | x `metBy`  y       = MetBy-    | x `overlaps` y     = Overlaps-    | x `overlappedBy` y = OverlappedBy-    | x `starts` y       = Starts-    | x `startedBy` y    = StartedBy-    | x `finishes` y     = Finishes-    | x `finishedBy` y   = FinishedBy-    | x `during` y       = During-    | x `contains` y     = Contains-    | otherwise          = Equals+relate+  :: (Intervallic i0 a, Intervallic i1 a) => i0 a -> i1 a -> IntervalRelation+relate x y | x `before` y       = Before+           | x `after` y        = After+           | x `meets` y        = Meets+           | x `metBy` y        = MetBy+           | x `overlaps` y     = Overlaps+           | x `overlappedBy` y = OverlappedBy+           | x `starts` y       = Starts+           | x `startedBy` y    = StartedBy+           | x `finishes` y     = Finishes+           | x `finishedBy` y   = FinishedBy+           | x `during` y       = During+           | x `contains` y     = Contains+           | otherwise          = Equals  -- | Compose two interval relations according to the rules of the algebra.---   The rules are enumerated according to <https://thomasalspaugh.org/pub/fnd/allen.html#BasicCompositionsTable this table>.-compose :: IntervalRelation-        -> IntervalRelation-        -> Data.Set.Set IntervalRelation+--   The rules are enumerated according to+-- <https://thomasalspaugh.org/pub/fnd/allen.html#BasicCompositionsTable this table>.+compose+  :: IntervalRelation -> IntervalRelation -> Data.Set.Set IntervalRelation compose x y = toSet (composeRelationLookup !! fromEnum x !! fromEnum y)  -- | Finds the complement of a @'Data.Set.Set' 'IntervalRelation'@.@@ -534,20 +606,21 @@ complement = Data.Set.difference intervalRelations  -- | Find the intersection of two 'Data.Set.Set's of 'IntervalRelation's.-intersection ::  Data.Set.Set IntervalRelation-                -> Data.Set.Set IntervalRelation-                -> Data.Set.Set IntervalRelation+intersection+  :: Data.Set.Set IntervalRelation+  -> Data.Set.Set IntervalRelation+  -> Data.Set.Set IntervalRelation intersection = Data.Set.intersection  -- | Find the union of two 'Data.Set.Set's of 'IntervalRelation's.-union :: Data.Set.Set IntervalRelation-      -> Data.Set.Set IntervalRelation-      -> Data.Set.Set IntervalRelation+union+  :: Data.Set.Set IntervalRelation+  -> Data.Set.Set IntervalRelation+  -> Data.Set.Set IntervalRelation union = Data.Set.union  -- | Find the converse of a @'Data.Set.Set' 'IntervalRelation'@. -converse :: Data.Set.Set IntervalRelation-         -> Data.Set.Set IntervalRelation+converse :: Data.Set.Set IntervalRelation -> Data.Set.Set IntervalRelation converse = Data.Set.map converseRelation  {- |@@ -585,15 +658,17 @@ -- >>> expand 1 1 (Interval (0::Int, 2::Int)) -- (-1, 3) ---expand :: (IntervalSizeable a b, Intervallic i a) =>-           b -- ^ duration to subtract from the 'begin'-        -> b -- ^ duration to add to the 'end'-        -> i a-        -> i a+expand+  :: (IntervalSizeable a b, Intervallic i a)+  => b -- ^ duration to subtract from the 'begin'+  -> b -- ^ duration to add to the 'end'+  -> i a+  -> i a expand l r p = setInterval p i-  where s = if l < moment' p then 0 else negate l-        e = if r < moment' p then 0 else r-        i = Interval (add s $ begin p, add e $ end p)+ where+  s = if l < moment' p then 0 else negate l+  e = if r < moment' p then 0 else r+  i = Interval (add s $ begin p, add e $ end p)  -- | Expands an @i a@ to "left". --@@ -623,14 +698,24 @@ -- >>> beginerval (2::Int) (0::Int) -- (0, 2) ---beginerval :: (IntervalSizeable a b) =>-           b -- ^ @dur@ation to add to the 'begin' -        -> a -- ^ the 'begin' point of the 'Interval'-        -> Interval a+beginerval+  :: (IntervalSizeable a b)+  => b -- ^ @dur@ation to add to the 'begin' +  -> a -- ^ the 'begin' point of the 'Interval'+  -> Interval a beginerval dur x = Interval (x, y)-    where i = Interval (x, x)-          d = max (moment' i) dur-          y = add d x+ where+  i = Interval (x, x)+  d = max (moment' i) dur+  y = add d x++-- | A synonym for `beginerval`+bi+  :: (IntervalSizeable a b)+  => b -- ^ @dur@ation to add to the 'begin' +  -> a -- ^ the 'begin' point of the 'Interval'+  -> Interval a+bi = beginerval {-# INLINABLE beginerval #-}  -- | Safely creates an 'Interval a' using @x@ as the 'end' and adding@@ -645,26 +730,54 @@ -- >>> enderval (2::Int) (0::Int) -- (-2, 0) ---enderval :: (IntervalSizeable a b) =>-          b -- ^ @dur@ation to subtract from the 'end' -       -> a -- ^ the 'end' point of the 'Interval'-       -> Interval a+enderval+  :: (IntervalSizeable a b)+  => b -- ^ @dur@ation to subtract from the 'end' +  -> a -- ^ the 'end' point of the 'Interval'+  -> Interval a enderval dur x = Interval (add (negate $ max (moment' i) dur) x, x)-    where i = Interval (x, x)+  where i = Interval (x, x)++-- | A synonym for `enderval`+ei+  :: (IntervalSizeable a b)+  => b -- ^ @dur@ation to subtract from the 'end' +  -> a -- ^ the 'end' point of the 'Interval'+  -> Interval a+ei = enderval {-# INLINABLE enderval #-} +-- | Safely creates an @'Interval'@ from a pair of endpoints.+-- IMPORTANT: This function uses 'beginerval', +-- thus if the second element of the pair is `<=` the first element,+-- the duration will be an @"Interval"@ of 'moment' duration.+--+-- >>> safeInterval (4, 5 ::Int)+-- (4, 5)+-- >>> safeInterval (4, 3 :: Int)+-- (4, 5)+--+safeInterval :: IntervalSizeable a b => (a, a) -> Interval a+safeInterval (b, e) = beginerval (diff e b) b++-- | A synonym for `safeInterval`+si :: IntervalSizeable a b => (a, a) -> Interval a+si = safeInterval+ -- | Creates a new Interval from the 'end' of an @i a@.-beginervalFromEnd :: (IntervalSizeable a b, Intervallic i a) =>-        b  -- ^ @dur@ation to add to the 'end' -     -> i a -- ^ the @i a@ from which to get the 'end'-     -> Interval a+beginervalFromEnd+  :: (IntervalSizeable a b, Intervallic i a)+  => b  -- ^ @dur@ation to add to the 'end' +  -> i a -- ^ the @i a@ from which to get the 'end'+  -> Interval a beginervalFromEnd d i = beginerval d (end i)  -- | Creates a new Interval from the 'begin' of an @i a@.-endervalFromBegin :: (IntervalSizeable a b, Intervallic i a) =>-       b -- ^ @dur@ation to subtract from the 'begin'  -    -> i a -- ^ the @i a@ from which to get the 'begin'-     -> Interval a+endervalFromBegin+  :: (IntervalSizeable a b, Intervallic i a)+  => b -- ^ @dur@ation to subtract from the 'begin'  +  -> i a -- ^ the @i a@ from which to get the 'begin'+  -> Interval a endervalFromBegin d i = enderval d (begin i)  -- | Safely creates a new @Interval@ with 'moment' length with 'begin' at @x@@@ -673,8 +786,7 @@ -- (10, 11) --  beginervalMoment :: (IntervalSizeable a b) => a -> Interval a-beginervalMoment x = beginerval (moment' i) x-    where i = Interval (x, x)+beginervalMoment x = beginerval (moment' i) x where i = Interval (x, x)  -- | Safely creates a new @Interval@ with 'moment' length with 'end' at @x@ --@@ -682,8 +794,7 @@ -- (9, 10) --  endervalMoment :: (IntervalSizeable a b) => a -> Interval a-endervalMoment x = enderval (moment' i) x-    where i = Interval (x, x)+endervalMoment x = enderval (moment' i) x where i = Interval (x, x)  -- | Creates a new @Interval@ spanning the extent x and y. --@@ -692,45 +803,49 @@ -- extenterval :: Intervallic i a => i a -> i a -> Interval a extenterval x y = Interval (s, e)-    where s = min (begin x) (begin y)-          e = max (end x) (end y)+ where+  s = min (begin x) (begin y)+  e = max (end x) (end y)  -- | Modifies the endpoints of second argument's interval by taking the difference---   from the first's input's 'begin'. +--   from the first's input's 'begin'.+--  -- >>> diffFromBegin (Interval ((5::Int), 6)) (Interval (10, 15)) -- (5, 10) -- -- >>> diffFromBegin (Interval ((1::Int), 2)) (Interval (3, 15)) -- (2, 14) ---diffFromBegin :: ( IntervalSizeable a b-                 , Functor i1-                 , Intervallic i0 a ) =>-    i0 a -> i1 a -> i1 b+diffFromBegin+  :: (IntervalSizeable a b, Functor i1, Intervallic i0 a)+  => i0 a+  -> i1 a+  -> i1 b diffFromBegin i = fmap (`diff` begin i)  -- | Modifies the endpoints of second argument's interval by taking the difference --   from the first's input's 'end'.+-- -- >>> diffFromEnd (Interval ((5::Int), 6)) (Interval (10, 15)) -- (4, 9) -- -- >>> diffFromEnd (Interval ((1::Int), 2)) (Interval (3, 15)) -- (1, 13) ---diffFromEnd :: ( IntervalSizeable a b-               , Functor i1-               , Intervallic i0 a ) =>-    i0 a -> i1 a -> i1 b+diffFromEnd+  :: (IntervalSizeable a b, Functor i1, Intervallic i0 a)+  => i0 a+  -> i1 a+  -> i1 b diffFromEnd i = fmap (`diff` end i)  -- | Changes the duration of an 'Intervallic' value to a moment starting at the  --   'begin' of the interval.--- +-- -- >>> momentize (Interval (6, 10)) -- (6, 7) ---momentize :: ( IntervalSizeable a b, Intervallic i a ) =>-    i a -> i a+momentize :: (IntervalSizeable a b, Intervallic i a) => i a -> i a momentize i = setInterval i (beginerval (moment' i) (begin i))  {- |@@ -769,7 +884,7 @@ -}  -- | Defines a predicate of two objects of type @a@.-type ComparativePredicateOf1 a  = (a -> a -> Bool)+type ComparativePredicateOf1 a = (a -> a -> Bool)  -- | Defines a predicate of two object of different types. type ComparativePredicateOf2 a b = (a -> b -> Bool)@@ -781,47 +896,43 @@ -- | Imposes a total ordering on @'Interval' a@ based on first ordering the  --   'begin's then the 'end's. instance (Ord a) => Ord (Interval a) where-    (<=) x y-      | begin x <  begin y = True-      | begin x == begin y = end x <= end y-      | otherwise = False-    (<)  x y-      | begin x <  begin y = True-      | begin x == begin y = end x < end y-      | otherwise = False+  (<=) x y | begin x < begin y  = True+           | begin x == begin y = end x <= end y+           | otherwise          = False+  (<) x y | begin x < begin y  = True+          | begin x == begin y = end x < end y+          | otherwise          = False  instance (Ord a) => Intervallic Interval a where-    getInterval = id-    setInterval _ x = x+  getInterval = id+  setInterval _ x = x  instance (Ord a) => IntervalCombinable Interval a where-    (><) x y-        | x `before` y = Just $ Interval (end x, begin y)-        | otherwise    = Nothing-    {-# INLINABLE (><) #-}+  (><) x y | x `before` y = Just $ Interval (end x, begin y)+           | otherwise    = Nothing+  {-# INLINABLE (><) #-} -    (<+>) x y-        | x `before` y = pure x <> pure y-        | otherwise    = pure ( extenterval x y )-    {-# INLINABLE (<+>) #-}+  (<+>) x y | x `before` y = pure x <> pure y+            | otherwise    = pure (extenterval x y)+  {-# INLINABLE (<+>) #-}  instance IntervalSizeable Int Int where-    moment = 1-    add    = (+)-    diff   = (-)+  moment = 1+  add    = (+)+  diff   = (-)  instance IntervalSizeable Integer Integer where-    moment = 1-    add    = (+)-    diff   = (-)+  moment = 1+  add    = (+)+  diff   = (-)  instance IntervalSizeable DT.Day Integer where-    moment = 1-    add    = addDays-    diff   = diffDays+  moment = 1+  add    = addDays+  diff   = diffDays  -- | Note that the @moment@ of this instance is a @'Data.Fixed.Pico'@ instance IntervalSizeable DT.UTCTime NominalDiffTime where-    moment   = toEnum 1 :: NominalDiffTime-    add      = addUTCTime-    diff     = diffUTCTime +  moment = toEnum 1 :: NominalDiffTime+  add    = addUTCTime+  diff   = diffUTCTime

@@ -0,0 +1,725 @@+{-|++This module provides functions for creating diagrams of intervals as text.+For example,++>>> let ref = bi 30 (0 :: Int)+>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]+>>> pretty $ simpleIntervalDiagram ref ivs +--                            +          -----               +                ------        +==============================++>>> import Data.Time+>>> let ref = bi 30 (fromGregorian 2022 5 6)+>>> let ivs = [ bi 2 (fromGregorian 2022 5 6), bi 5 (fromGregorian 2022 5 10)]+>>> pretty $ simpleIntervalDiagram ref ivs +--                            +    -----                     +==============================++Such diagrams are useful for documentation, examples,+and learning to reason with the interval algebra.++There are two main functions available: ++* @'parseIntervalDiagram'@:+exposes all available options+and gives the most flexibility in producing diagrams+* @'simpleIntervalDiagram'@+produces simple diagram using defaults.+-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-}++module IntervalAlgebra.IntervalDiagram+  (+  -- * Make nice-looking diagrams of intervals+  {-|+  All these functions return an @'IntervalDiagram'@,+  which can then be pretty printed using the @'Prettyprinter.pretty'@ function.+  -}+    parseIntervalDiagram+  , simpleIntervalDiagram++  -- * Diagram options+  , IntervalDiagramOptions(..)+  , defaultIntervalDiagramOptions+  , AxisPlacement(..)++  -- * Internal types+  , IntervalText+  , IntervalDiagram++  -- * Errors+  , IntervalTextLineParseError(..)+  , AxisParseError(..)+  , IntervalDiagramOptionsError(..)+  , IntervalDiagramParseError(..)+  ) where++import           Data.Foldable                  ( Foldable(toList) )+import qualified Data.IntMap.NonEmpty          as NEM+import qualified Data.List.NonEmpty            as NE+                                         hiding ( toList )+import           Data.Maybe                     ( fromMaybe+                                                , isNothing+                                                )+import           Data.Text                      ( Text )+import           IntervalAlgebra.Core+import           Prettyprinter+import           Witch                          ( From(..)+                                                , into+                                                )++{-+The key Type in this module is the IntervalDiagram,+which has several components.+Each component in sections below organized as follows:+ * Type(s)+ * (optional) Instances+ * (optional) parser+ * (optional) utilities+-}++{-------------------------------------------------------------------------------+  IntervalText+-------------------------------------------------------------------------------}++{-|+@IntervalText@ is an internal type+which contains an @Interval a@ and the @Char@ used to print+the interval in a diagram.++The @Interval a@ type needs to be an instance of @IntervalSizeable a b@;+Moreover, the type @b@ should be castable to @Int@,+using its @'Witch.From' b Int@  instance.++>>> import PrettyPrinter (pretty)+>>> import IntervalAlgebra (beginerval)+>>> pretty $ MkIntervalText '-' (beginerval 5 (0::Int))+-----+>>> pretty $ MkIntervalText '*' (beginerval 10 (0::Int))+**********+-}+-- NOTE: This type *could* be a PairedInterval,+-- but I didn't do that in order to reduce depeendencies.+data IntervalText a = MkIntervalText Char (Interval a)+  deriving (Eq, Show)++instance (Ord a) => Intervallic IntervalText a where+  getInterval (MkIntervalText _ x) = x+  setInterval (MkIntervalText c _) = MkIntervalText c++instance Functor IntervalText where+  fmap f (MkIntervalText c i) = MkIntervalText c (fmap f i)++instance (Enum b, IntervalSizeable a b) => Pretty (IntervalText a) where+  pretty (MkIntervalText c i) = pretty $ replicate (fromEnum (duration i)) c++instance From (Char, Interval a) (IntervalText a) where+  from = uncurry MkIntervalText++instance From (IntervalText a) Char where+  from (MkIntervalText c _) = c++instance From (IntervalText a) (Interval a) where+  from (MkIntervalText _ i) = i++{-------------------------------------------------------------------------------+  IntervalTextLine+-------------------------------------------------------------------------------}++{-|+The @IntervalTextLine@ is an internal type+containing a list of @IntervalText@.++Values of this type should only be created+through the 'parseIntervalTextLine' function,+which checks that the inputs are parsed correctly and+uses the 'makeIntervalLine' function to form intervals +that will be pretty-printed correctly.++>>> let i1 =  MkIntervalText '*' (beginerval 10 (5::Int))+>>> let i2  = MkIntervalText '-' (beginerval 2 (1::Int))+>>> let x = parseIntervalTextLine [] [i1, i2] +>>> pretty x+UnsortedIntervals+>>> let i1 =  MkIntervalText '*' (beginerval 10 (5::Int))+>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2] +>>> pretty x+ConcurringIntervals+>>> let i1 =  MkIntervalText '*' (beginerval 10 ((-1)::Int))+>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine []  [i1, i2] +>>> pretty x+BeginsLessThanZero+>>> let i1 =  MkIntervalText '*' (beginerval  5 (0::Int))+>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+*****     --+>>> let i1 =  MkIntervalText '*' (beginerval  5 (5::Int))+>>> let i2  = MkIntervalText '-' (beginerval 2 (10::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+     *****--+>>> let i1 =  MkIntervalText '*' (beginerval  1 (5::Int))+>>> let i2  = MkIntervalText '-' (beginerval 1 (7::Int))+>>> let x = parseIntervalTextLine [] [i1, i2]+>>> pretty x+     * -+>>> let i1 =  MkIntervalText '*' (beginerval  3 (5::Int))+>>> let i2 = MkIntervalText '-' (beginerval 5 (10::Int))+>>> let i3 = MkIntervalText '#' (beginerval 1 17)+>>> pretty $ parseIntervalTextLine [] [i1, i2, i3]+     ***  -----  #+-}+data IntervalTextLine a = MkIntervalTextLine [IntervalText a] [Text]+  deriving Show++{-+NOTE:+a pretty-printed @IntervalTextLine@ does not print its labels.+Line labels are printed by @IntervalDiagram@.+This is because line labels are vertically aligned across lines,+and without the other lines we don't know where to align labels.+-}+instance Pretty (IntervalTextLine Int) where+  pretty (MkIntervalTextLine ivs _) =+    concatWith (<>) (fmap (\x -> indent (begin x) (pretty x)) ivs)++instance Pretty (Either IntervalTextLineParseError (IntervalTextLine Int)) where+  pretty (Left  e) = pretty $ show e+  pretty (Right l) = pretty l++{-|+A type representing errors that may occur+when a list of @IntervalText@ is parsed into a @IntervalTextLine@.+-}+data IntervalTextLineParseError =+    -- | The inputs contains concurring intervals. +    --   All inputs should be @'disjoint'@.+      ConcurringIntervals+    -- | The inputs are not sorted.+    | UnsortedIntervals+    -- | At least one of the inputs has a @'begin'@ less than zero.+    | BeginsLessThanZero+     deriving (Eq, Show, Ord)++{-|+Parses a list of @IntervalText Int@+into an @IntervalTextLine Int@,+handling the types of parse errors that could occur.++See 'IntervalTextLine' for examples.+-}+parseIntervalTextLine+  :: [Text]+  -> [IntervalText Int]+  -> Either IntervalTextLineParseError (IntervalTextLine Int)+parseIntervalTextLine labs l =+  let vals = NE.nonEmpty l+  in  if+        | any (uncurry concur) (pairs l) -> Left ConcurringIntervals+        | (not . isSorted . fmap getInterval) l -> Left UnsortedIntervals+        | any ((< 0) . begin) l -> Left BeginsLessThanZero+        | otherwise -> case vals of+          Nothing -> Right (MkIntervalTextLine [] [])+          Just v ->+            -- The use of makeIntervalLine is important here+            -- in order to get the intervals positioned correctly+            Right $ MkIntervalTextLine (toList (makeIntervalLine v)) labs+ where+  {-+  Modifies the inputs sequentially+  so that the begin of one interval is+  shifted based on the end of the previous interval.  +  This function assumes that the inputs are sorted and disjoint.+  -}+  makeIntervalLine+    :: NE.NonEmpty (IntervalText Int) -> NE.NonEmpty (IntervalText Int)+  makeIntervalLine x =+    NE.head x NE.:| zipWith diffFromEnd (toList x) (NE.tail x)++  -- Creates all pairs of a list+  pairs = go+   where+    go []       = []+    go (x : xs) = fmap (x, ) xs <> go xs+  isSorted xs = and $ zipWith (<=) xs (tail xs)+++{-------------------------------------------------------------------------------+  Axis Config and Components +-------------------------------------------------------------------------------}++{-|+A type representing options of where to place the axis in a printed diagram.+-}+data AxisPlacement =+  -- | Print the axis at the top of the diagram+    Top+  -- | Print the axis at the bottom of the diagram +  | Bottom deriving (Eq, Show)++{-|+Type containing data that can be presented below the axis+on an @IntervalDiagram@.+-}+newtype AxisLabels = MkAxisLabels (NEM.NEIntMap Char)+  deriving (Eq, Show)++{-|+A type containing information about how to configure pretty of an @'Axis'@+-}+data AxisConfig = MkAxisConfig+  { placement :: Maybe AxisPlacement+  , labels    :: Maybe AxisLabels+  }+  deriving (Eq, Show)++prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann]+prettyAxisLabels pos (MkAxisLabels labs) = do+  let ints  = NEM.keys labs+  let marks = toList $ NEM.elems labs+  let labPos =+        NE.head ints : zipWith (\x y -> y - x - 1) (toList ints) (NE.tail ints)+  let out =+        [ hcat $ fmap (\i -> indent i (pretty '|')) labPos+        , hcat $ zipWith indent labPos (pretty <$> marks)+        ]+  case pos of+    Top    -> reverse out+    Bottom -> out++{-------------------------------------------------------------------------------+  Axis +-------------------------------------------------------------------------------}++{-|+A type containing the data necessary to print an axis in an 'IntervalDiagram'.++Use 'parseAxis' for construction.++>>> let ref = MkIntervalText '=' (beginerval 10 (0::Int))+ ++>>> let b = parseAxis [] (Just Top) ref+>>> pretty b +==========++>>> let c = parseAxis [(4, 'a'), (6, 'b')] (Just Top) ref+>>> pretty c +    a b+    | |+==========++>>> let d = parseAxis [(4, 'a'), (6, 'b')] (Just Bottom) ref+>>> pretty d+==========+    | |+    a b++>>> let e = parseAxis [(4, 'a'), (4, 'b')] (Just Top) ref+>>> pretty e+MultipleLabelAtSamePosition++>>> let f = parseAxis [(4, 'a'), (19, 'b')] (Just Top) ref+>>> pretty f+LabelsBeyondReference++-}+data Axis = MkAxis+  { refInterval :: IntervalText Int+  , config      :: AxisConfig+  }+  deriving (Eq, Show)++instance Pretty Axis where+  pretty (MkAxis ref (MkAxisConfig Nothing  _      )) = emptyDoc+  pretty (MkAxis ref (MkAxisConfig (Just _) Nothing)) = pretty ref+  pretty (MkAxis ref (MkAxisConfig (Just Bottom) (Just labels))) =+    vcat $ pretty ref : prettyAxisLabels Bottom labels+  pretty (MkAxis ref (MkAxisConfig (Just Top) (Just labels))) =+    vcat $ prettyAxisLabels Top labels ++ [pretty ref]++instance Pretty ( Either AxisParseError Axis ) where+  pretty (Left  e) = pretty $ show e+  pretty (Right a) = pretty a++{-|+A type representing errors that can occur when parsing an axis.+-}+data AxisParseError =+  -- | Indicates that the position of one ore more axis labels+  --   is outside the reference interval+    LabelsBeyondReference+  -- | Indicates that multiple labels have been put at the same position+  | MultipleLabelAtSamePosition+  deriving (Eq, Show)++{-|+Safely create an @'Axis'@.++See @'Axis'@ for examples.+-}+parseAxis+  :: [(Int, Char)]+  -> Maybe AxisPlacement+  -> IntervalText Int+  -> Either AxisParseError Axis+-- if the axis is not shown then any labels are ignored+parseAxis _ Nothing  i = Right $ MkAxis i (MkAxisConfig Nothing Nothing)+parseAxis l (Just p) i = do+  let labels          = NEM.fromList <$> NE.nonEmpty l+  let labPos          = NEM.keys <$> labels+  let inputLabelCount = length l+  if+    |+-- Flag if any of the label positions are beyond the reference interval+      any (\x -> x < begin i || x > end i) (fmap fst l) -> Left+      LabelsBeyondReference+    |+-- Identify if the number of elements in the input list is different +-- from the number of elements after transforming the list+-- into a nonempty IntMap.+-- If different, then flag.+      inputLabelCount > 0 && fmap length labels /= Just inputLabelCount -> Left+      MultipleLabelAtSamePosition+    |+-- Otherwise, we have a good Axis.+      otherwise -> Right+    $  MkAxis i (MkAxisConfig (Just p) (fmap MkAxisLabels labels))++{-------------------------------------------------------------------------------+  IntervalDiagramOptions+-------------------------------------------------------------------------------}++{-|+A record containing options for printing an @'IntervalDiagram'@.+-}+data IntervalDiagramOptions = MkIntervalDiagramOptions+  { -- | See 'PrettyPrinter.LayoutOptions'+    layout      :: LayoutOptions+    -- | Number of spaces to pad the left of the diagram by.+    --   Must be greater than or equal to @0@.+  , leftPadding :: Int+  }+  deriving (Eq, Show)++{-|+A type representing the types of invalid @'IntervalDiagramOptions'@.+-}+data IntervalDiagramOptionsError =+  -- | Indicates that @'PageWidth'@ is @Unbounded@,+  --   which isn't allowed for an IntervalDiagram.+    UnboundedPageWidth+  -- | Indicates that the left padding in the option is < 0.+  | LeftPaddingLessThan0+  deriving (Eq, Show)++{-|+Takes an initial set of options+and checks that the values are valid,+returning an error if not.++Sorry the indirection in that the input type is also in the output type.+Better might be something like+PossibleOptions -> Either Error ValidOptions+But this works and this code is not exposed to the user.+-}+parseDiagramOptions+  :: IntervalDiagramOptions+  -> Either IntervalDiagramOptionsError IntervalDiagramOptions+parseDiagramOptions opts = if+  | leftPadding opts < 0 -> Left LeftPaddingLessThan0+  | layoutPageWidth (layout opts) == Unbounded -> Left UnboundedPageWidth+  | otherwise            -> Right opts+  where isSorted xs = and $ zipWith (<=) xs (tail xs)++-- | Default 'IntervalDiagramOptions' options+defaultIntervalDiagramOptions :: IntervalDiagramOptions+defaultIntervalDiagramOptions = MkIntervalDiagramOptions defaultLayoutOptions 0++{-------------------------------------------------------------------------------+  IntervalDiagram+-------------------------------------------------------------------------------}++{-|+Type containing the data needed to pretty print an interval document.+-}+data IntervalDiagram a = MkIntervalDiagram+  { -- | The reference interval is the interval based on which 'intervalValues'+   --    are transformed.+   --    It is the only interval that retains the original type.+    reference      :: Interval a+  , axis           :: Axis+  , intervalValues :: [IntervalTextLine Int]+  , options        :: IntervalDiagramOptions+  }+  deriving Show++{-|+Type representing errors that may occur+when parsing inputs into an @'IntervalDiagram'@.++Not every possible state of a "bad" diagram is currently captured+by 'parseIntervalDiagram'.+In particular, line labels can be a source of problems.+The labels accept arbitrary @Text@.+Newline characters in a label would, for example, throw things off.+Labels that extend beyond the @'PrettyPrinter.pageWidth'@+will also cause problems.++-}+data IntervalDiagramParseError =+  -- | Indicates that one or more of the input intervals extend beyond the axis.+    IntervalsExtendBeyondAxis+  -- | Indicates that the reference axis is longer than the @'PageWidth'@+  --   given in the @'IntervalDiagramOptions'@.+  | AxisWiderThanAvailable+  -- | Indicates that left padding is >0 +  --   and no axis is printed. +  --   This is considered an error because it be impossible +  --   to know the 'begin' values of intervals in a printed @IntervalDiagram@ +  --   that has been padded and has no axis.+  | PaddingWithNoAxis+  -- | Indicates that an error occurring when checking the document options.+  | OptionsError IntervalDiagramOptionsError+  -- | Indicates something is wrong with the @'Axis'@.+  | AxisError AxisParseError+  -- | Indicates that at least one error occurred when parsing the interval lines.+  | IntervalLineError IntervalTextLineParseError+  deriving (Eq, Show)++instance (IntervalSizeable a b) => Pretty (IntervalDiagram a) where+  pretty (MkIntervalDiagram _ axis ivs opts) = do++    -- Create a list of pretty IntervalLines+    let intervalLines = fmap pretty ivs++    -- Get the length of the reference interval+    -- in order to determine the column position of line labels+    let refDur        = end (refInterval axis)++    -- Position line labels relative to the reference interval+    -- and the end of the last interval in a line.+    -- NOTE: +    -- This is tricky because the intervals+    -- in a parsed IntervalTextLine are referenced relative+    -- to the previous interval in the line,+    -- not to the reference interval. +    -- See use of makeIntervalLine in parseIntervalTextLine.+    -- This why the intervalLineEnd function is used to determine +    -- the end of the intervals in a line.+    let labelIndents  = fmap (diff refDur . intervalLineEnd) ivs++    -- Create a list of the line label docs+    let labelLines =+          zipWith (\i l -> indent l (prettyLineLabel i)) ivs labelIndents++    -- Zip together each interval line and its labels horizontally,+    -- then stack all the lines.+    let intervalDiagram = vsep $ zipWith (<>) intervalLines labelLines++    -- Add the the axis in the appropriate position.+    let mainDiagram = case (placement . config) axis of+          Nothing     -> intervalDiagram+          Just Top    -> vcat [pretty axis, intervalDiagram]+          Just Bottom -> vcat [intervalDiagram, pretty axis]++    -- Add any left padding.+    indent (leftPadding opts) mainDiagram++   where+    intervalLineEnd :: IntervalTextLine Int -> Int+    intervalLineEnd (MkIntervalTextLine x _) = sum $ fmap end x++    prettyLineLabel :: IntervalTextLine Int -> Doc ann+    prettyLineLabel (MkIntervalTextLine _ t) = if null t+      then emptyDoc+      else space <> pretty ("<-" :: Text) <> space <> pretty t++instance (IntervalSizeable a b) =>+  Pretty (Either IntervalDiagramParseError (IntervalDiagram a)) where+  pretty (Left  e) = pretty $ show e+  pretty (Right d) = pretty d++{-|+Parse inputs into a pretty printable document.++This function provides the most flexibility in producing interval diagrams.+++To create @'IntervalText'@ values use its @'From'@ instance, as in:++>>> let mkIntrvl c d b = into @(IntervalText Int) (c, bi d (b :: Int))++Here's a basic diagram that shows+how to put more than one interval interval on a line:++>>> let x = mkIntrvl  '=' 20 0+>>> let l1 = [ mkIntrvl '-' 1 4 ]+>>> let l2 = [ mkIntrvl '*' 3 5, mkIntrvl '*' 5 10, mkIntrvl 'x' 1 17 ]+>>> let l3 = [ mkIntrvl '#' 2 18]+>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions  [] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]+    -               +     ***  *****  x  +                  ##+====================++We can put the axis on the top:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Top) x [ (l1, []), (l2, []), (l3, []) ]+====================+    -               +     ***  *****  x  +                  ##++++We can annotate the axis:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [(5, 'a')] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ]+    -               +     ***  *****  x  +                  ##+====================+     |+     a+++We can also annotate each line with labels:++>>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Bottom) x [ (l1, ["line1"]), (l2, ["line2a", "line2b"]), (l3, ["line3"])  ]+    -                <- [line1]+     ***  *****  x   <- [line2a, line2b]+                  ## <- [line3]+====================+++The parser tries to check that the data can be printed.+For example, the default @'Prettyprinter.LayoutOptions'@ is 80 characters.+Providing an reference interval wider than 80 characters+results in an error.++>>> let x = mkIntrvl '=' 100 5+>>> let ivs = [ mkIntrvl '-' 1 1 ]+>>> parseIntervalDiagram defaultIntervalDiagramOptions [] Nothing x [ (ivs, []) ]+Left AxisWiderThanAvailable++See 'IntervalDiagramParseError' for all the cases handled.++-}+parseIntervalDiagram+  :: (Ord a, IntervalSizeable a b, Enum b)+  => IntervalDiagramOptions+  -- ^ Document options (see 'IntervalDiagramOptions')+  -> [(Int, Char)]+  -- ^ A list of axis labels+  -> Maybe AxisPlacement+  -- ^ An optional 'AxisPlacement' of the axis+  -> IntervalText a+  -- ^ The reference (axis interval)+  -> [([IntervalText a], [Text])]+  -- ^ Intervals to include in the diagram.+  -- Each item in the list creates a new line in the printed diagram.+  -- Text creates an optional label for the line.+  -> Either IntervalDiagramParseError (IntervalDiagram a)+parseIntervalDiagram opts labels placement ref ivs =+  case parseDiagramOptions opts of+    Left  e -> Left $ OptionsError e+    Right o -> if+      |+-- check that the duration of the reference intervall+-- does not exceed the page width+        checkAvailableChar (layoutPageWidth $ layout o)+      -> Left AxisWiderThanAvailable+      |+-- check none of the interval extend beyond the reference interval+        any (extendsBeyond ref) (concatMap fst ivs)+      -> Left IntervalsExtendBeyondAxis+      |+-- check that padding == 0 and axis is displayed+        leftPadding o > 0 && isNothing placement+      -> Left PaddingWithNoAxis+      | otherwise+      -> let parsedReferencedIntervals = traverse+               (\(i, t) -> parseIntervalTextLine t (rereferenceL ref i))+               ivs+         in  case parsedReferencedIntervals of+               Left e -> Left $ IntervalLineError e+               Right vals ->+                 let parsedAxis =+                       parseAxis labels placement (rereference ref ref)+                 in  case parsedAxis of+                       Left e -> Left $ AxisError e+                       Right axis ->+                         Right $ MkIntervalDiagram (getInterval ref) axis vals o+ where+  extendsBeyond =+    before <|> meets <|> overlaps <|> overlappedBy <|> metBy <|> after+  checkAvailableChar (AvailablePerLine i _) = fromEnum (duration ref) > i+  checkAvailableChar Unbounded              = True+  {-+    Shifts the endpoints of an interval to be referenced from another interval,+    so that the 'begin' of the reference interval acts as the "zero" point.+  -}+  rereference x = fmap (fromEnum . (`diff` begin x))+  rereferenceL x = fmap (rereference x)++{-|+Given a reference interval and a list of intervals,+produces an 'IntervalDiagram' with one line per interval,+using the 'defaultIntervalDiagramOptions'. ++>>> import Data.Maybe (fromMaybe)+>>> pretty $ simpleIntervalDiagram (bi 10 (0 :: Int)) (fmap (bi 1) [0..9])+-+ -+  -+   -+    -+     -+      -+       -+        -+         -+==========++>>> let ref = bi 30 (0 :: Int)+>>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ]+>>> pretty $ simpleIntervalDiagram ref ivs +--+          -----+                ------+==============================++>>> pretty $ simpleIntervalDiagram ref (fromMaybe [] (gapsWithin ref ivs))+  --------+               -+                      --------+==============================++-}+simpleIntervalDiagram+  :: (Ord a, IntervalSizeable a b, Intervallic i a, Enum b)+  => i a -- ^ The axis interval+  -> [i a] -- ^ List of intervals to be printed one per line+  -> Either IntervalDiagramParseError (IntervalDiagram a)+simpleIntervalDiagram ref ivs = parseIntervalDiagram+  defaultIntervalDiagramOptions+  []+  (Just Bottom)+  (MkIntervalText '=' (getInterval ref))+  (fmap (\x -> (pure $ MkIntervalText '-' $ getInterval x, [])) ivs)

@@ -13,122 +13,146 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} -module IntervalAlgebra.IntervalUtilities (+module IntervalAlgebra.IntervalUtilities+  (      -- * Fold over sequential intervals-      combineIntervals-    , combineIntervalsL-    , gaps-    , gapsL-    , gapsWithin+    combineIntervals+  , combineIntervalsL+  , gaps+  , gapsL+  , gapsWithin      -- * Operations on Meeting sequences of paired intervals-    , foldMeetingSafe-    , formMeetingSequence+  , foldMeetingSafe+  , formMeetingSequence      -- * Withering functions      -- ** Clear containers based on predicate-    , nothingIf-    , nothingIfNone-    , nothingIfAny-    , nothingIfAll+  , nothingIf+  , nothingIfNone+  , nothingIfAny+  , nothingIfAll      -- ** Filter containers based on predicate-    , filterBefore-    , filterMeets-    , filterOverlaps-    , filterFinishedBy-    , filterContains-    , filterStarts-    , filterEquals-    , filterStartedBy-    , filterDuring-    , filterFinishes-    , filterOverlappedBy-    , filterMetBy-    , filterAfter-    , filterDisjoint-    , filterNotDisjoint-    , filterConcur-    , filterWithin-    , filterEnclose-    , filterEnclosedBy+  , filterBefore+  , filterMeets+  , filterOverlaps+  , filterFinishedBy+  , filterContains+  , filterStarts+  , filterEquals+  , filterStartedBy+  , filterDuring+  , filterFinishes+  , filterOverlappedBy+  , filterMetBy+  , filterAfter+  , filterDisjoint+  , filterNotDisjoint+  , filterConcur+  , filterWithin+  , filterEnclose+  , filterEnclosedBy      -- * Misc utilities-    , relations-    , relationsL-    , intersect-    , clip-    , durations-) where+  , relations+  , relationsL+  , intersect+  , clip+  , durations+  ) where -import safe GHC.Show              ( Show )-import safe GHC.Int               ( Int )-import safe Control.Applicative   ( Applicative(pure)-                                  , (<*>) )-import qualified Control.Foldl as L-import safe Control.Monad         ( Functor(fmap) )-import safe Data.Bool             ( Bool, otherwise, not, (||), (&&) )-import safe Data.Eq               ( Eq((==)) )-import safe Data.Foldable         ( Foldable(null, foldl', toList)-                                  , all-                                  , any-                                  , or )-import safe Data.Function         ( ($), (.), flip )-import safe Data.Monoid           ( Monoid(mempty) )-import safe Data.Maybe            ( Maybe(..)-                                  , maybe-                                  , maybeToList )-import safe Data.Ord              ( Ord(min, max) )-import safe Data.Semigroup        ( Semigroup((<>)) )-import safe Data.Traversable      ( Traversable(sequenceA) )-import safe Data.Tuple            ( fst )-import safe Safe                  ( headMay, lastMay, initSafe, tailSafe)-import safe Witherable            ( Filterable(filter)-                                  , Witherable(..)-                                  , mapMaybe-                                  , catMaybes )-import safe IntervalAlgebra.Core ( (<|>),-                                  begin,-                                  end,-                                  after,-                                  before,-                                  beginerval,-                                  beginervalFromEnd,-                                  endervalFromBegin,-                                  concur,-                                  contains,-                                  disjoint,-                                  during,-                                  enclose,-                                  enclosedBy,-                                  enderval,-                                  equals,-                                  extenterval,-                                  finishedBy,-                                  finishes,-                                  meets,-                                  metBy,-                                  notDisjoint,-                                  overlappedBy,-                                  overlaps,-                                  relate,-                                  startedBy,-                                  starts,-                                  within,-                                  ComparativePredicateOf1,-                                  ComparativePredicateOf2,-                                  Interval,-                                  IntervalCombinable((<+>), (><)),-                                  IntervalRelation(..),-                                  IntervalSizeable(diff, duration),-                                  Intervallic(..) )-import safe IntervalAlgebra.PairedInterval-                                  ( PairedInterval-                                  , makePairedInterval-                                  , getPairData-                                  , equalPairData )+import safe      Control.Applicative            ( (<*>)+                                                , Applicative(pure)+                                                )+import qualified Control.Foldl                 as L+import safe      Control.Monad                  ( Functor(fmap) )+import safe      Data.Bool                      ( (&&)+                                                , Bool+                                                , not+                                                , otherwise+                                                , (||)+                                                )+import safe      Data.Eq                        ( Eq((==)) )+import safe      Data.Foldable                  ( Foldable(foldl', null, toList)+                                                , all+                                                , any+                                                , or+                                                )+import safe      Data.Function                  ( ($)+                                                , (.)+                                                , flip+                                                )+import safe      Data.Maybe                     ( Maybe(..)+                                                , maybe+                                                , maybeToList+                                                )+import safe      Data.Monoid                    ( Monoid(mempty) )+import safe      Data.Ord                       ( Ord(max, min) )+import safe      Data.Semigroup                 ( Semigroup((<>)) )+import safe      Data.Traversable               ( Traversable(sequenceA) )+import safe      Data.Tuple                     ( fst )+import safe      GHC.Int                        ( Int )+import safe      GHC.Show                       ( Show )+import safe      IntervalAlgebra.Core           ( (<|>)+                                                , ComparativePredicateOf1+                                                , ComparativePredicateOf2+                                                , Interval+                                                , IntervalCombinable+                                                  ( (<+>)+                                                  , (><)+                                                  )+                                                , IntervalRelation(..)+                                                , IntervalSizeable+                                                  ( diff+                                                  , duration+                                                  )+                                                , Intervallic(..)+                                                , after+                                                , before+                                                , begin+                                                , beginerval+                                                , beginervalFromEnd+                                                , concur+                                                , contains+                                                , disjoint+                                                , during+                                                , enclose+                                                , enclosedBy+                                                , end+                                                , enderval+                                                , endervalFromBegin+                                                , equals+                                                , extenterval+                                                , finishedBy+                                                , finishes+                                                , meets+                                                , metBy+                                                , notDisjoint+                                                , overlappedBy+                                                , overlaps+                                                , relate+                                                , startedBy+                                                , starts+                                                , within+                                                )+import safe      IntervalAlgebra.PairedInterval ( PairedInterval+                                                , equalPairData+                                                , getPairData+                                                , makePairedInterval+                                                )+import safe      Safe                           ( headMay+                                                , initSafe+                                                , lastMay+                                                , tailSafe+                                                )+import safe      Witherable                     ( Filterable(filter)+                                                , Witherable(..)+                                                , catMaybes+                                                , mapMaybe+                                                )   @@ -142,24 +166,23 @@  -- An internal utility function for creating a @Fold@ that maps over a structure -- by consecutive pairs into a new structure.-makeFolder :: (Monoid (m b), Applicative m) =>-   (a -> a -> b)-   -> L.Fold a (m b)+makeFolder :: (Monoid (m b), Applicative m) => (a -> a -> b) -> L.Fold a (m b) makeFolder f = L.Fold step begin done-  where-    begin = (mempty, Nothing)-    step (fs, Nothing) y = (fs, Just y)-    step (fs, Just x) y  = (fs <> pure (f x y), Just y)-    done (fs, _) = fs+ where+  begin = (mempty, Nothing)+  step (fs, Nothing) y = (fs, Just y)+  step (fs, Just x ) y = (fs <> pure (f x y), Just y)+  done (fs, _) = fs  -- Used to combine two lists by combining the last element of @x@ and the first  -- element of @y@ by @f@. The combining function @f@ will generally return a  -- singleton list in the case that the last of x and head of y can be combined -- or a two element list in the case they cannot.-listCombiner :: (Maybe a -> Maybe a -> [a]) -- ^ f-                -> [a] -- ^ x-                -> [a] -- ^ y-                -> [a]+listCombiner+  :: (Maybe a -> Maybe a -> [a]) -- ^ f+  -> [a] -- ^ x+  -> [a] -- ^ y+  -> [a] listCombiner f x y = initSafe x <> f (lastMay x) (headMay y) <> tailSafe y {-# INLINABLE listCombiner #-} @@ -168,22 +191,19 @@ -- -- >>> relationsL [iv 1 0, iv 1 1]  -- [Meets]-relationsL :: (Foldable f, Intervallic i a )=>-       f (i a)-    -> [IntervalRelation]+relationsL :: (Foldable f, Intervallic i a) => f (i a) -> [IntervalRelation] relationsL = relations  -- | A generic form of 'relations' which can output any 'Applicative' and ---   'Monoid' structure. +--   'Monoid' structure.+-- -- >>> (relations [iv 1 0, iv 1 1]) :: [IntervalRelation (Interval Int)] -- [Meets] ---relations :: ( Foldable f-              , Applicative m-              , Intervallic i a-              , Monoid (m IntervalRelation ))=>-        f (i a)-     -> m IntervalRelation+relations+  :: (Foldable f, Applicative m, Intervallic i a, Monoid (m IntervalRelation))+  => f (i a)+  -> m IntervalRelation relations = L.fold (makeFolder relate) {-# INLINABLE relations #-} @@ -192,23 +212,26 @@ --  -- >>> intersect (iv 5 0) (iv 2 3) -- Just (3, 5)-intersect :: (Intervallic i a, IntervalSizeable a b) =>-    i a -> i a -> Maybe (Interval a)-intersect x y-    | disjoint x y = Nothing-    | otherwise    = Just $ beginerval (diff e b) b-        where b = max (begin x) (begin y)-              e = min (end x) (end y)+--+intersect+  :: (Intervallic i a, IntervalSizeable a b) => i a -> i a -> Maybe (Interval a)+intersect x y | disjoint x y = Nothing+              | otherwise    = Just $ beginerval (diff e b) b+ where+  b = max (begin x) (begin y)+  e = min (end x) (end y)  -- Internal function which folds over a structure by consecutive pairs, returing -- gaps between each pair (@Nothing@ if no such gap exists).-gapsM:: ( IntervalCombinable i a-        , Traversable f-        , Monoid (f (Maybe (Interval a)))-        , Applicative f) =>-      f (i a) ->-      f (Maybe (Interval a))-gapsM =  L.fold (makeFolder (\i j -> getInterval i >< getInterval j))+gapsM+  :: ( IntervalCombinable i a+     , Traversable f+     , Monoid (f (Maybe (Interval a)))+     , Applicative f+     )+  => f (i a)+  -> f (Maybe (Interval a))+gapsM = L.fold (makeFolder (\i j -> getInterval i >< getInterval j)) {-# INLINABLE gapsM #-}  -- | Returns a @Maybe@ container of intervals consisting of the gaps @@ -217,25 +240,29 @@ -- -- >>> gaps [iv 4 1, iv 4 8, iv 3 11] ---gaps:: ( IntervalCombinable i a-        , Traversable f-        , Monoid (f (Maybe (Interval a)))-        , Applicative f) =>-      f (i a) ->-      Maybe (f (Interval a))-gaps = sequenceA.gapsM+gaps+  :: ( IntervalCombinable i a+     , Traversable f+     , Monoid (f (Maybe (Interval a)))+     , Applicative f+     )+  => f (i a)+  -> Maybe (f (Interval a))+gaps = sequenceA . gapsM {-# INLINABLE gaps #-}  -- | Returns a (possibly empty) list of intervals consisting of the gaps between --   intervals in the input container. *To work properly, the input should be  --   sorted*. This version outputs a list. See 'gaps' for a version that lifts --   the result to same input structure @f@.-gapsL :: ( IntervalCombinable i a-         , Applicative f-         , Monoid (f (Maybe (Interval a)))-         , Traversable f) =>-      f (i a) ->-      [Interval a]+gapsL+  :: ( IntervalCombinable i a+     , Applicative f+     , Monoid (f (Maybe (Interval a)))+     , Traversable f+     )+  => f (i a)+  -> [Interval a] gapsL x = maybe [] toList (gaps x) {-# INLINABLE gapsL #-} @@ -243,9 +270,9 @@ -- -- >>> durations [iv 9 1, iv 10 2, iv 1 5] -- [9,10,1]-durations :: (Functor f, Intervallic i a, IntervalSizeable a b)=>-       f (i a)-    -> f b+--+durations+  :: (Functor f, Intervallic i a, IntervalSizeable a b) => f (i a) -> f b durations = fmap duration  -- | In the case that x y are not disjoint, clips y to the extent of x.@@ -255,18 +282,21 @@ -- -- >>> clip (iv 3 0) (iv 2 4) -- Nothing-clip :: (Intervallic i0 a, Intervallic i1 a, IntervalSizeable a b)=>-       i0 a-    -> i1 a-    -> Maybe (Interval a)+--+clip+  :: (Intervallic i0 a, Intervallic i1 a, IntervalSizeable a b)+  => i0 a+  -> i1 a+  -> Maybe (Interval a) clip x y-   | overlaps x y     = Just $ enderval   (diff (end x) (begin y)) (end x)-   | overlappedBy x y = Just $ beginerval (diff (end y) (begin x)) (begin x)-   | jx x y           = Just (getInterval x)-   | jy x y           = Just (getInterval y)-   | otherwise        = Nothing {- disjoint x y case -}-   where jy = equals <|> startedBy <|> contains <|> finishedBy-         jx = starts <|> during <|> finishes+  | overlaps x y     = Just $ enderval (diff (end x) (begin y)) (end x)+  | overlappedBy x y = Just $ beginerval (diff (end y) (begin x)) (begin x)+  | jx x y           = Just (getInterval x)+  | jy x y           = Just (getInterval y)+  | otherwise        = Nothing {- disjoint x y case -}+ where+  jy = equals <|> startedBy <|> contains <|> finishedBy+  jx = starts <|> during <|> finishes {-# INLINABLE clip #-}  -- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are *not* disjoint@@ -279,35 +309,36 @@ -- >>> gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12] -- Just [(5, 7),(9, 10)] ---gapsWithin :: ( Applicative f-               , Witherable f -               , Monoid (f (Interval a))-               , Monoid (f (Maybe (Interval a)))-               , IntervalSizeable a b-               , Intervallic i0 a-               , IntervalCombinable i1 a-               ) =>-        i0 a  -- ^ i+gapsWithin+  :: ( Applicative f+     , Witherable f+     , Monoid (f (Interval a))+     , Monoid (f (Maybe (Interval a)))+     , IntervalSizeable a b+     , Intervallic i0 a+     , IntervalCombinable i1 a+     )+  => i0 a  -- ^ i   -> f (i1 a) -- ^ x   -> Maybe (f (Interval a))-gapsWithin i x -  | null ivs = Nothing -  | otherwise = Just res-    where s   = pure (endervalFromBegin 0 i)-          e   = pure (beginervalFromEnd 0 i)-          ivs = mapMaybe (clip i) (filterNotDisjoint i x)-          res = catMaybes $ gapsM ( s <> ivs <> e ) +gapsWithin i x | null ivs  = Nothing+               | otherwise = Just res+ where+  s   = pure (endervalFromBegin 0 i)+  e   = pure (beginervalFromEnd 0 i)+  ivs = mapMaybe (clip i) (filterNotDisjoint i x)+  res = catMaybes $ gapsM (s <> ivs <> e) {-# INLINABLE gapsWithin #-}  -- The Box is an internal type used to hold accumulated, combined intervals in  -- 'combineIntervalsL'. newtype Box a = Box { unBox :: [a] } -packIntervalBoxes :: (Intervallic i a)=> [i a] -> [Box (Interval a)]-packIntervalBoxes  = fmap (\z -> Box [getInterval z])+packIntervalBoxes :: (Intervallic i a) => [i a] -> [Box (Interval a)]+packIntervalBoxes = fmap (\z -> Box [getInterval z])  instance (Ord a) => Semigroup (Box (Interval a)) where-    Box x <> Box y = Box $ listCombiner (<->) x y+  Box x <> Box y = Box $ listCombiner (<->) x y  -- | Returns a container of intervals where any intervals that meet or share support --   are combined into one interval. *To work properly, the input should @@ -315,14 +346,17 @@ -- -- >>> combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)]-combineIntervals :: ( Applicative f-                    , Ord a-                    , Intervallic i a-                    , Monoid (f (Interval a))-                    , Foldable f ) =>-      f (i a) ->-      f (Interval a)-combineIntervals x = +--+combineIntervals+  :: ( Applicative f+     , Ord a+     , Intervallic i a+     , Monoid (f (Interval a))+     , Foldable f+     )+  => f (i a)+  -> f (Interval a)+combineIntervals x =   foldl' (\x y -> x <> pure y) mempty (combineIntervalsL $ toList x)   -- TODO: surely combineIntervals and combineIntervalsL could be combined {-# INLINABLE combineIntervals #-}@@ -333,18 +367,16 @@ -- -- >>> combineIntervalsL [iv 10 0, iv 5 2, iv 2 10, iv 2 13] -- [(0, 12),(13, 15)]-combineIntervalsL :: (Intervallic i a)=> [i a] -> [Interval a]+--+combineIntervalsL :: (Intervallic i a) => [i a] -> [Interval a] combineIntervalsL l = unBox $ foldl' (<>) (Box []) (packIntervalBoxes l) {-# INLINABLE combineIntervalsL #-}  -- Internal function for combining maybe intervals in the 'combineIntervalsL'  -- function-(<->) :: (IntervalCombinable i a) =>-       Maybe (i a)-    -> Maybe (i a)-    -> [Interval a]-(<->) Nothing Nothing   = []-(<->) Nothing (Just y)  = [getInterval y]+(<->) :: (IntervalCombinable i a) => Maybe (i a) -> Maybe (i a) -> [Interval a]+(<->) Nothing  Nothing  = []+(<->) Nothing  (Just y) = [getInterval y] (<->) (Just x) Nothing  = [getInterval x] (<->) (Just x) (Just y) = (<+>) (getInterval x) (getInterval y) {-# INLINABLE (<->) #-}@@ -352,12 +384,14 @@ -- | Given a predicate combinator, a predicate, and list of intervals, returns  --   the input unchanged if the predicate combinator is @True@. Otherwise, returns --   an empty list. See 'nothingIfAny' and 'nothingIfNone' for examples.-nothingIf :: (Monoid (f (i a)), Filterable f)=>-     ((i a -> Bool) -> f (i a) -> Bool) -- ^ e.g. 'any' or 'all'+nothingIf+  :: (Monoid (f (i a)), Filterable f)+  => ((i a -> Bool) -> f (i a) -> Bool) -- ^ e.g. 'any' or 'all'   -> (i a -> Bool) -- ^ predicate to apply to each element of input list   -> f (i a)   -> Maybe (f (i a))-nothingIf quantifier predicate x = if quantifier predicate x then Nothing else Just x+nothingIf quantifier predicate x =+  if quantifier predicate x then Nothing else Just x  -- | Returns the 'Nothing' if *none* of the element of input satisfy --   the predicate condition.@@ -373,11 +407,12 @@ -- >>> nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5] -- Just [(3, 6),(5, 6)] ---nothingIfNone :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (i a -> Bool) -- ^ predicate to apply to each element of input list+nothingIfNone+  :: (Monoid (f (i a)), Foldable f, Filterable f)+  => (i a -> Bool) -- ^ predicate to apply to each element of input list   -> f (i a)   -> Maybe (f (i a))-nothingIfNone = nothingIf (\f x -> (not.any f) x)+nothingIfNone = nothingIf (\f x -> (not . any f) x)  -- | Returns 'Nothing' if *any* of the element of input satisfy the predicate condition. --@@ -386,29 +421,33 @@ -- -- >>> nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] -- Nothing-nothingIfAny :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (i a -> Bool) -- ^ predicate to apply to each element of input list+--+nothingIfAny+  :: (Monoid (f (i a)), Foldable f, Filterable f)+  => (i a -> Bool) -- ^ predicate to apply to each element of input list   -> f (i a)   -> Maybe (f (i a)) nothingIfAny = nothingIf any  -- | Returns 'Nothing' if *all* of the element of input satisfy the predicate condition.+-- -- >>> nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] -- Nothing-nothingIfAll :: (Monoid (f (i a)), Foldable f, Filterable f)=>-    (i a -> Bool) -- ^ predicate to apply to each element of input list+--+nothingIfAll+  :: (Monoid (f (i a)), Foldable f, Filterable f)+  => (i a -> Bool) -- ^ predicate to apply to each element of input list   -> f (i a)   -> Maybe (f (i a)) nothingIfAll = nothingIf all  -- | Creates a function for filtering a 'Witherable.Filterable' of @i1 a@s  --   by comparing the @Interval a@s that of an @i0 a@. -makeFilter :: ( Filterable f-               , Intervallic i0 a-               , Intervallic i1 a) =>-        ComparativePredicateOf2 (i0 a) (i1 a)-      -> i0 a-      -> (f (i1 a) -> f (i1 a))+makeFilter+  :: (Filterable f, Intervallic i0 a, Intervallic i1 a)+  => ComparativePredicateOf2 (i0 a) (i1 a)+  -> i0 a+  -> (f (i1 a) -> f (i1 a)) makeFilter f p = Witherable.filter (f p)  {- | @@ -416,51 +455,52 @@ a (potentially different) 'Intervallic' type using the corresponding interval predicate function. -}-filterOverlaps, filterOverlappedBy, filterBefore, filterAfter,-  filterStarts, filterStartedBy, filterFinishes, filterFinishedBy,-  filterMeets, filterMetBy, filterDuring, filterContains, filterEquals,-  filterDisjoint, filterNotDisjoint, filterConcur, filterWithin,-  filterEnclose, filterEnclosedBy ::-    ( Filterable f , Intervallic i0 a, Intervallic i1 a) =>-    i0 a -> f (i1 a) -> f (i1 a)-filterOverlaps          = makeFilter overlaps-filterOverlappedBy      = makeFilter overlappedBy-filterBefore            = makeFilter before-filterAfter             = makeFilter after-filterStarts            = makeFilter starts-filterStartedBy         = makeFilter startedBy-filterFinishes          = makeFilter finishes-filterFinishedBy        = makeFilter finishedBy-filterMeets             = makeFilter meets-filterMetBy             = makeFilter metBy-filterDuring            = makeFilter during-filterContains          = makeFilter contains-filterEquals            = makeFilter equals-filterDisjoint          = makeFilter disjoint-filterNotDisjoint       = makeFilter notDisjoint-filterConcur            = makeFilter concur-filterWithin            = makeFilter within-filterEnclose           = makeFilter enclose-filterEnclosedBy        = makeFilter enclosedBy+filterOverlaps, filterOverlappedBy, filterBefore, filterAfter, filterStarts, filterStartedBy, filterFinishes, filterFinishedBy, filterMeets, filterMetBy, filterDuring, filterContains, filterEquals, filterDisjoint, filterNotDisjoint, filterConcur, filterWithin, filterEnclose, filterEnclosedBy+  :: (Filterable f, Intervallic i0 a, Intervallic i1 a)+  => i0 a+  -> f (i1 a)+  -> f (i1 a)+filterOverlaps = makeFilter overlaps+filterOverlappedBy = makeFilter overlappedBy+filterBefore = makeFilter before+filterAfter = makeFilter after+filterStarts = makeFilter starts+filterStartedBy = makeFilter startedBy+filterFinishes = makeFilter finishes+filterFinishedBy = makeFilter finishedBy+filterMeets = makeFilter meets+filterMetBy = makeFilter metBy+filterDuring = makeFilter during+filterContains = makeFilter contains+filterEquals = makeFilter equals+filterDisjoint = makeFilter disjoint+filterNotDisjoint = makeFilter notDisjoint+filterConcur = makeFilter concur+filterWithin = makeFilter within+filterEnclose = makeFilter enclose+filterEnclosedBy = makeFilter enclosedBy  -- | Folds over a list of Paired Intervals and in the case that the 'getPairData'  --   is equal between two sequential meeting intervals, these two intervals are  --   combined into one. This function is "safe" in the sense that if the input is --   invalid and contains any sequential pairs of intervals with an @IntervalRelation@, --   other than 'Meets', then the function returns an empty list. -foldMeetingSafe :: (Eq b, Ord a, Show a)  =>-           [ PairedInterval b a ] -- ^ Be sure this only contains intervals +foldMeetingSafe+  :: (Eq b, Ord a, Show a)+  => [PairedInterval b a] -- ^ Be sure this only contains intervals                                    --   that sequentially 'meets'.-        -> [ PairedInterval b a ]+  -> [PairedInterval b a] foldMeetingSafe l = maybe [] (getMeeting . foldMeeting) (parseMeeting l)  -- | Folds over a list of Meeting Paired Intervals and in the case that the 'getPairData'  --   is equal between two sequential meeting intervals, these two intervals are  --   combined into one.  -foldMeeting :: (Eq b, Ord a, Show a) =>-            Meeting [PairedInterval b a ]-        ->  Meeting [PairedInterval b a ]-foldMeeting (Meeting l) = foldl' joinMeetingPairedInterval (Meeting []) (packMeeting l)+foldMeeting+  :: (Eq b, Ord a, Show a)+  => Meeting [PairedInterval b a]+  -> Meeting [PairedInterval b a]+foldMeeting (Meeting l) =+  foldl' joinMeetingPairedInterval (Meeting []) (packMeeting l)  -- This type identifies that @a@ contains intervals that sequentially meet one  -- another.@@ -472,38 +512,40 @@  -- Test a list of intervals to be sure they all meet; if not return Nothing. parseMeeting :: Intervallic i a => [i a] -> Maybe (Meeting [i a])-parseMeeting x-    | all ( == Meets ) (relationsL x) = Just $ Meeting x-    | otherwise = Nothing+parseMeeting x | all (== Meets) (relationsL x) = Just $ Meeting x+               | otherwise                     = Nothing  -- A specific case of 'joinMeeting' for @PairedIntervals@.-joinMeetingPairedInterval :: (Eq b, Ord a, Show a) =>-                  Meeting [PairedInterval b a]-               -> Meeting [PairedInterval b a]-               -> Meeting [PairedInterval b a]+joinMeetingPairedInterval+  :: (Eq b, Ord a, Show a)+  => Meeting [PairedInterval b a]+  -> Meeting [PairedInterval b a]+  -> Meeting [PairedInterval b a] joinMeetingPairedInterval = joinMeeting equalPairData  -- A general function for combining any two @Meeting [i a]@ by 'listCombiner'.-joinMeeting :: Intervallic i a =>-       ComparativePredicateOf1 (i a)-    -> Meeting [ i a ]-    -> Meeting [ i a ]-    -> Meeting [ i a ]-joinMeeting f (Meeting x) (Meeting y) = Meeting $ listCombiner (join2MeetingWhen f) x y+joinMeeting+  :: Intervallic i a+  => ComparativePredicateOf1 (i a)+  -> Meeting [i a]+  -> Meeting [i a]+  -> Meeting [i a]+joinMeeting f (Meeting x) (Meeting y) =+  Meeting $ listCombiner (join2MeetingWhen f) x y  -- The intervals @x@ and @y@ should meet! The predicate function @p@ determines -- when the two intervals that meet should be combined.-join2MeetingWhen :: Intervallic i a =>-       ComparativePredicateOf1 (i a)-    -> Maybe (i a)-    -> Maybe (i a)-    -> [i a]-join2MeetingWhen p Nothing Nothing   = []-join2MeetingWhen p Nothing (Just y)  = [y]+join2MeetingWhen+  :: Intervallic i a+  => ComparativePredicateOf1 (i a)+  -> Maybe (i a)+  -> Maybe (i a)+  -> [i a]+join2MeetingWhen p Nothing  Nothing  = []+join2MeetingWhen p Nothing  (Just y) = [y] join2MeetingWhen p (Just x) Nothing  = [x]-join2MeetingWhen p (Just x) (Just y)-    | p x y      = [ setInterval y (extenterval x y) ]-    | otherwise  =  pure x <> pure y+join2MeetingWhen p (Just x) (Just y) | p x y = [setInterval y (extenterval x y)]+                                     | otherwise = pure x <> pure y  {- |  Takes two *ordered* events, x <= y, and "disjoins" them in the case that the@@ -512,34 +554,33 @@ relations between x and y. If the states of x and y are equal and x is not  before y, then x and y are combined into a single event.  -}-disjoinPaired :: ( Eq b-                 , Monoid b-                 , Show a-                 , IntervalSizeable a c) =>-       (PairedInterval b) a-    -> (PairedInterval b) a-    -> Meeting [(PairedInterval b) a]+disjoinPaired+  :: (Eq b, Monoid b, Show a, IntervalSizeable a c)+  => (PairedInterval b) a+  -> (PairedInterval b) a+  -> Meeting [(PairedInterval b) a] disjoinPaired o e = case relate x y of-     Before     -> Meeting [ x, evp e1 b2 mempty, y ]-     Meets      -> foldMeeting $ Meeting [ x, y ]-     Overlaps   -> foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2 ]-     FinishedBy -> foldMeeting $ Meeting [ evp b1 b2 s1, ev i2 sc ]-     Contains   -> foldMeeting $ Meeting [ evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1 ]-     Starts     -> foldMeeting $ Meeting [ ev i1 sc, evp e1 e2 s2 ]-     _          -> Meeting [ ev i1 sc ] {- Equals case -}-   where x  = min o e-         y  = max o e-         i1 = getInterval x-         i2 = getInterval y-         s1 = getPairData x-         s2 = getPairData y-         sc = s1 <> s2-         b1 = begin x-         b2 = begin y-         e1 = end x-         e2 = end y-         ev = flip makePairedInterval-         evp = \b e s -> ev (beginerval (diff e b) b) s+  Before     -> Meeting [x, evp e1 b2 mempty, y]+  Meets      -> foldMeeting $ Meeting [x, y]+  Overlaps   -> foldMeeting $ Meeting [evp b1 b2 s1, evp b2 e1 sc, evp e1 e2 s2]+  FinishedBy -> foldMeeting $ Meeting [evp b1 b2 s1, ev i2 sc]+  Contains   -> foldMeeting $ Meeting [evp b1 b2 s1, evp b2 e2 sc, evp e2 e1 s1]+  Starts     -> foldMeeting $ Meeting [ev i1 sc, evp e1 e2 s2]+  _          -> Meeting [ev i1 sc] {- Equals case -}+ where+  x  = min o e+  y  = max o e+  i1 = getInterval x+  i2 = getInterval y+  s1 = getPairData x+  s2 = getPairData y+  sc = s1 <> s2+  b1 = begin x+  b2 = begin y+  e1 = end x+  e2 = end y+  ev = flip makePairedInterval+  evp b e = ev (beginerval (diff e b) b) {-# INLINABLE disjoinPaired #-}  {- | @@ -550,16 +591,19 @@ compared to input events. The second of the pair are disjoint events that still need to be compared to be input events.  -}-recurseDisjoin :: ( Monoid b, Eq b, IntervalSizeable a c, Show a ) =>-       ([(PairedInterval b) a ], [(PairedInterval b) a ])-    -> [(PairedInterval b) a ]-    -> [(PairedInterval b) a ]-recurseDisjoin (acc, o:os) []     = acc <> (o:os)           -- the "final" pattern-recurseDisjoin (acc, [])   []     = acc                 -- another "final" pattern -recurseDisjoin (acc, [])   (e:es) = recurseDisjoin (acc, [e]) es -- the "initialize" pattern-recurseDisjoin (acc, o:os) (e:es)                       -- the "operating" patterns +recurseDisjoin+  :: (Monoid b, Eq b, IntervalSizeable a c, Show a)+  => ([(PairedInterval b) a], [(PairedInterval b) a])+  -> [(PairedInterval b) a]+  -> [(PairedInterval b) a]+recurseDisjoin (acc, o : os) []       = acc <> (o : os)           -- the "final" pattern+recurseDisjoin (acc, []    ) []       = acc                 -- another "final" pattern +recurseDisjoin (acc, []    ) (e : es) = recurseDisjoin (acc, [e]) es -- the "initialize" pattern+recurseDisjoin (acc, o : os) (e : es)+  |                       -- the "operating" patterns       -- If input event is equal to the first comparator, skip the comparison.-    | e == o    = recurseDisjoin (acc, o:os) es+    e == o = recurseDisjoin (acc, o : os) es+  |       {- If o is either before or meets e, then       the first of the combined events can be put into the accumulator. @@ -567,13 +611,17 @@      is before or meets e, then we are assured that all periods up to the       beginning of o are fully disjoint and subsequent input events will       not overlap these in any way. -}-    | (before <|> meets) o e = recurseDisjoin (acc <> nh, recurseDisjoin ([], nt) os ) es+    (before <|> meets) o e = recurseDisjoin+    (acc <> nh, recurseDisjoin ([], nt) os)+    es+  |      --The standard recursive operation.-    | otherwise = recurseDisjoin (acc,  recurseDisjoin ([], n) os ) es-  where n  = getMeeting $ disjoinPaired o e-        nh = maybeToList (headMay n)-        nt = tailSafe n+    otherwise = recurseDisjoin (acc, recurseDisjoin ([], n) os) es+ where+  n  = getMeeting $ disjoinPaired o e+  nh = maybeToList (headMay n)+  nt = tailSafe n {-# INLINABLE recurseDisjoin #-}  {- | @@ -584,16 +632,14 @@ combined using the Monoid '<>' function, hence the pair data must be a  'Monoid' instance. -}-formMeetingSequence :: ( Eq b-                       , Show a-                       , Monoid b-                       , IntervalSizeable a c) =>-           [ PairedInterval b a ]-        -> [ PairedInterval b a ]+formMeetingSequence+  :: (Eq b, Show a, Monoid b, IntervalSizeable a c)+  => [PairedInterval b a]+  -> [PairedInterval b a] formMeetingSequence x-  | null x  = []+  | null x = []   | allMeet x && not (hasEqData x) = x-  | otherwise  = formMeetingSequence (recurseDisjoin ([], []) x)+  | otherwise = formMeetingSequence (recurseDisjoin ([], []) x)   -- recurseDisjoin ([], []) (recurseDisjoin ([], []) (recurseDisjoin ([], []) x))     -- the multiple passes of recurseDisjoin is to handle the situation where the @@ -606,7 +652,7 @@ {-# INLINABLE formMeetingSequence #-}  allMeet :: (Ord a) => [PairedInterval b a] -> Bool-allMeet x = all ( == Meets) ( relationsL x )+allMeet x = all (== Meets) (relationsL x)  hasEqData :: (Eq b) => [PairedInterval b a] -> Bool hasEqData x = or (L.fold (makeFolder (==)) (fmap getPairData x) :: [Bool])

@@ -12,42 +12,43 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-} -module IntervalAlgebra.PairedInterval (-      PairedInterval-    , Empty(..)-    , makePairedInterval-    , getPairData-    , intervals-    , equalPairData-    , toTrivialPair-    , trivialize-) where+module IntervalAlgebra.PairedInterval+  ( PairedInterval+  , Empty(..)+  , makePairedInterval+  , getPairData+  , intervals+  , equalPairData+  , toTrivialPair+  , trivialize+  ) where -import safe IntervalAlgebra.Core    ( Interval-                                    , Intervallic(..)-                                    , before-                                    , IntervalCombinable(..)-                                    , ComparativePredicateOf1-                                    , extenterval )-import safe Witherable              ( Filterable(filter) )-import safe Data.Bifunctor          ( Bifunctor(bimap) )-import safe GHC.Generics            ( Generic )-import safe Data.Binary             ( Binary )-import safe Control.DeepSeq         ( NFData )+import safe      Control.DeepSeq                ( NFData )+import safe      Data.Bifunctor                 ( Bifunctor(bimap) )+import safe      Data.Binary                    ( Binary )+import safe      GHC.Generics                   ( Generic )+import safe      IntervalAlgebra.Core           ( ComparativePredicateOf1+                                                , Interval+                                                , IntervalCombinable(..)+                                                , Intervallic(..)+                                                , before+                                                , extenterval+                                                )+import safe      Witherable                     ( Filterable(filter) )  -- | An @Interval a@ paired with some other data of type @b@. newtype PairedInterval b a = PairedInterval (Interval a, b)     deriving (Eq, Generic)  instance (Ord a) => Intervallic (PairedInterval b) a where-    getInterval (PairedInterval x)        = fst x-    setInterval (PairedInterval (x, y)) i = PairedInterval (i, y)+  getInterval (PairedInterval x) = fst x+  setInterval (PairedInterval (x, y)) i = PairedInterval (i, y)  instance Functor (PairedInterval b) where-    fmap f (PairedInterval (x, y)) = PairedInterval (fmap f x, y)+  fmap f (PairedInterval (x, y)) = PairedInterval (fmap f x, y)  instance Bifunctor PairedInterval where-    bimap f g (PairedInterval (x, y)) = PairedInterval (fmap g x, f y)+  bimap f g (PairedInterval (x, y)) = PairedInterval (fmap g x, f y)  instance (NFData a, NFData b) => NFData (PairedInterval b a) instance (Binary a, Binary b) => Binary (PairedInterval b a)@@ -56,20 +57,19 @@ --   part. instance (Eq a, Eq b, Ord a) => Ord (PairedInterval b a) where   (<=) x y = getInterval x <= getInterval y-  (<) x y  = getInterval x <  getInterval y+  (<) x y = getInterval x < getInterval y  instance (Show b, Show a, Ord a) => Show (PairedInterval b a) where-    show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}"+  show x = "{" ++ show (getInterval x) ++ ", " ++ show (getPairData x) ++ "}" -instance (Ord a, Eq b, Monoid b) => +instance (Ord a, Eq b, Monoid b) =>           IntervalCombinable (PairedInterval b) a where-    (><) x y = fmap (makePairedInterval mempty) (getInterval x >< getInterval y)+  (><) x y = fmap (makePairedInterval mempty) (getInterval x >< getInterval y) -    (<+>) x y-        | x `before` y = pure x <> pure y-        | otherwise    = pure $-            makePairedInterval (getPairData x <> getPairData y)-                                (extenterval x y) +  (<+>) x y+    | x `before` y = pure x <> pure y+    | otherwise = pure+    $ makePairedInterval (getPairData x <> getPairData y) (extenterval x y)  -- | Make a paired interval.  makePairedInterval :: b -> Interval a -> PairedInterval b a@@ -88,12 +88,13 @@ intervals = fmap getInterval  -- | Empty is used to trivially lift an @Interval a@ into a @PairedInterval@.-data Empty = Empty deriving (Eq, Ord, Show)-instance Semigroup Empty where -    x <> y = Empty+data Empty = Empty+  deriving (Eq, Ord, Show)+instance Semigroup Empty where+  x <> y = Empty instance Monoid Empty where-    mempty = Empty-    mappend x y = x <> y+  mempty = Empty+  mappend x y = x <> y  -- | Lifts an @Interval a@ into a @PairedInterval Empty a@, where @Empty@ is a --   trivial type that contains no data.

@@ -12,44 +12,53 @@ This module is useful if creating a new instance of interval types that you want to test.  -}-+{- HLINT ignore -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-module IntervalAlgebra.RelationProperties (-   IntervalRelationProperties(..)-) where -import Test.QuickCheck            ( (===)-                                  , (==>)-                                  , Property-                                  , Arbitrary (arbitrary) )-import Data.Maybe                 ( fromJust, isJust, isNothing )-import Data.Time as DT            ( Day-                                  , UTCTime-                                  , NominalDiffTime-                                  )-import Data.Set                   ( Set-                                  , member-                                  , disjointUnion-                                  , fromList )-import IntervalAlgebra.Core-import IntervalAlgebra.Arbitrary+module IntervalAlgebra.RelationProperties+  ( IntervalRelationProperties(..)+  ) where -allIArelations:: (Ord a) => [ComparativePredicateOf1 (Interval a)]-allIArelations =   [  equals-                    , meets-                    , metBy-                    , before-                    , after-                    , starts-                    , startedBy-                    , finishes-                    , finishedBy-                    , overlaps-                    , overlappedBy-                    , during-                    , contains ] +import           Data.Maybe                     ( fromJust+                                                , isJust+                                                , isNothing+                                                )+import           Data.Set                       ( Set+                                                , disjointUnion+                                                , fromList+                                                , member+                                                )+import           Data.Time                     as DT+                                                ( Day+                                                , NominalDiffTime+                                                , UTCTime+                                                )+import           IntervalAlgebra.Arbitrary+import           IntervalAlgebra.Core+import           Test.QuickCheck                ( (===)+                                                , (==>)+                                                , Arbitrary(arbitrary)+                                                , Property+                                                ) +allIArelations :: (Ord a) => [ComparativePredicateOf1 (Interval a)]+allIArelations =+  [ equals+  , meets+  , metBy+  , before+  , after+  , starts+  , startedBy+  , finishes+  , finishedBy+  , overlaps+  , overlappedBy+  , during+  , contains+  ]+ -- | A collection of properties for the interval algebra. Some of these come from  --   figure 2 in  [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). class ( IntervalSizeable a b ) => IntervalRelationProperties a b where@@ -63,12 +72,12 @@     -- predicate between two interval is equivalent to the relation of two intervals      -- being in the set of relations.     prop_predicate_unions :: Ord a =>-          Set IntervalRelation +          Set IntervalRelation         -> ComparativePredicateOf2 (Interval a) (Interval a)-        -> Interval a          -> Interval a+        -> Interval a         -> Property-    prop_predicate_unions s pred i0 i1 = +    prop_predicate_unions s pred i0 i1 =       pred i0 i1 === (relate i0 i1 `elem` s)      prop_IAbefore :: Interval a -> Interval a -> Property@@ -104,44 +113,44 @@         where k = beginerval (diff (begin i) (begin j)) (begin j)               l = beginerval (diff (end j)   (end i))   (end i) -    prop_disjoint_predicate :: (Ord a) =>        -          Interval a +    prop_disjoint_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property +        -> Property     prop_disjoint_predicate = prop_predicate_unions disjointRelations disjoint -    prop_notdisjoint_predicate :: (Ord a) =>        -          Interval a +    prop_notdisjoint_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property -    prop_notdisjoint_predicate = +        -> Property+    prop_notdisjoint_predicate =       prop_predicate_unions (complement disjointRelations) notDisjoint -    prop_concur_predicate :: (Ord a) =>        -          Interval a +    prop_concur_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property -    prop_concur_predicate = -      prop_predicate_unions (complement disjointRelations) concur +        -> Property+    prop_concur_predicate =+      prop_predicate_unions (complement disjointRelations) concur -    prop_within_predicate :: (Ord a) =>        -          Interval a +    prop_within_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property +        -> Property     prop_within_predicate = prop_predicate_unions withinRelations within -    prop_enclosedBy_predicate :: (Ord a) =>        -          Interval a +    prop_enclosedBy_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property +        -> Property     prop_enclosedBy_predicate = prop_predicate_unions withinRelations enclosedBy -    prop_enclose_predicate :: (Ord a) =>        -          Interval a +    prop_enclose_predicate :: (Ord a) =>+          Interval a         -> Interval a-        -> Property +        -> Property     prop_enclose_predicate = prop_predicate_unions (converse withinRelations) enclose  instance IntervalRelationProperties Int Int instance IntervalRelationProperties Day Integer-instance IntervalRelationProperties UTCTime NominalDiffTime +instance IntervalRelationProperties UTCTime NominalDiffTime

@@ -2,55 +2,67 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}-module AxiomsSpec (spec) where+module AxiomsSpec+  ( spec+  ) where -import Test.Hspec                 ( hspec, describe, it, Spec, )-import Test.Hspec.QuickCheck      ( modifyMaxSuccess )-import Test.QuickCheck            ( quickCheck-                                  , generate-                                  , Gen(..)-                                  , Arbitrary(arbitrary)-                                  , Property-                                  , Testable(property) )-import Data.Time                  ( Day, UTCTime )-import IntervalAlgebra.Axioms     ( IntervalAxioms(..) )+import           Data.Time                      ( Day+                                                , UTCTime+                                                )+import           IntervalAlgebra.Axioms         ( IntervalAxioms(..) )+import           Test.Hspec                     ( Spec+                                                , describe+                                                , hspec+                                                , it+                                                )+import           Test.Hspec.QuickCheck          ( modifyMaxSuccess )+import           Test.QuickCheck                ( Arbitrary(arbitrary)+                                                , Gen(..)+                                                , Property+                                                , Testable(property)+                                                , generate+                                                , quickCheck+                                                )  +testScale :: Int+testScale = 1000+ spec :: Spec spec = do -  describe "An Axiomatization of Interval Time" $-    modifyMaxSuccess (*1000) $-    do-      it "M1" $ property (prop_IAaxiomM1 @Int)-      it "M1" $ property (prop_IAaxiomM1 @Day)-      it "M1" $ property (prop_IAaxiomM1 @UTCTime)+  describe "An Axiomatization of Interval Time"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "M1" $ property (prop_IAaxiomM1 @Int)+        it "M1" $ property (prop_IAaxiomM1 @Day)+        it "M1" $ property (prop_IAaxiomM1 @UTCTime) -      it "M2" $ property (prop_IAaxiomM2 @Int)-      it "M2" $ property (prop_IAaxiomM2 @Day)-      it "M2" $ property (prop_IAaxiomM2 @UTCTime) +        it "M2" $ property (prop_IAaxiomM2 @Int)+        it "M2" $ property (prop_IAaxiomM2 @Day)+        it "M2" $ property (prop_IAaxiomM2 @UTCTime) -      it "ML1" $ property (prop_IAaxiomML1 @Int)-      it "ML1" $ property (prop_IAaxiomML1 @Day)-      it "ML1" $ property (prop_IAaxiomML1 @UTCTime)+        it "ML1" $ property (prop_IAaxiomML1 @Int)+        it "ML1" $ property (prop_IAaxiomML1 @Day)+        it "ML1" $ property (prop_IAaxiomML1 @UTCTime) -      it "ML2" $ property (prop_IAaxiomML2 @Int)-      it "ML2" $ property (prop_IAaxiomML2 @Day)-      it "ML2" $ property (prop_IAaxiomML2 @UTCTime)+        it "ML2" $ property (prop_IAaxiomML2 @Int)+        it "ML2" $ property (prop_IAaxiomML2 @Day)+        it "ML2" $ property (prop_IAaxiomML2 @UTCTime) -      it "M3" $ property (prop_IAaxiomM3 @Int)-      it "M3" $ property (prop_IAaxiomM3 @Day)-      it "M3" $ property (prop_IAaxiomM3 @UTCTime)+        it "M3" $ property (prop_IAaxiomM3 @Int)+        it "M3" $ property (prop_IAaxiomM3 @Day)+        it "M3" $ property (prop_IAaxiomM3 @UTCTime) -      it "M4" $ property (prop_IAaxiomM4 @Int)-      it "M4" $ property (prop_IAaxiomM4 @Day)-      it "M4" $ property (prop_IAaxiomM4 @UTCTime)+        it "M4" $ property (prop_IAaxiomM4 @Int)+        it "M4" $ property (prop_IAaxiomM4 @Day)+        it "M4" $ property (prop_IAaxiomM4 @UTCTime) -      it "M5" $ property (prop_IAaxiomM5 @Int)-      it "M5" $ property (prop_IAaxiomM5 @Day)-      it "M5" $ property (prop_IAaxiomM5 @UTCTime)+        it "M5" $ property (prop_IAaxiomM5 @Int)+        it "M5" $ property (prop_IAaxiomM5 @Day)+        it "M5" $ property (prop_IAaxiomM5 @UTCTime) -      it "M4.1" $ property (prop_IAaxiomM4_1 @Int)-      it "M4.1" $ property (prop_IAaxiomM4_1 @Day)-      it "M4.1" $ property (prop_IAaxiomM4_1 @UTCTime)+        it "M4.1" $ property (prop_IAaxiomM4_1 @Int)+        it "M4.1" $ property (prop_IAaxiomM4_1 @Day)+        it "M4.1" $ property (prop_IAaxiomM4_1 @UTCTime) 

@@ -1,7 +1,7 @@ module Main where -import Test.Hspec-import AxiomsSpec+import           AxiomsSpec+import           Test.Hspec  main :: IO () main = hspec spec

@@ -1,7 +1,7 @@ module Main where -import Test.Hspec-import RelationPropertiesSpec +import           RelationPropertiesSpec+import           Test.Hspec  main :: IO () main = hspec spec

@@ -2,69 +2,77 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}-module RelationPropertiesSpec (spec) where--import Test.Hspec                 ( hspec, describe, it, Spec, )-import Test.Hspec.QuickCheck      ( modifyMaxSuccess )-import Test.QuickCheck-import Data.Time-import IntervalAlgebra.RelationProperties     ( IntervalRelationProperties(..) )+module RelationPropertiesSpec+  ( spec+  ) where +import           Data.Time+import           IntervalAlgebra.RelationProperties+                                                ( IntervalRelationProperties(..)+                                                )+import           Test.Hspec                     ( Spec+                                                , describe+                                                , hspec+                                                , it+                                                )+import           Test.Hspec.QuickCheck          ( modifyMaxSuccess )+import           Test.QuickCheck +testScale = 100  spec :: Spec spec = do-  describe "Interval Algebra relation properties for Interval Int" $-      modifyMaxSuccess (*100) $-    do-      it "before"   $ property (prop_IAbefore @Int)-      it "starts"   $ property (prop_IAstarts @Int)-      it "finishes" $ property (prop_IAfinishes @Int)-      it "overlaps" $ property (prop_IAoverlaps @Int)-      it "during"   $ property (prop_IAduring @Int)-      it "disjoint" $ property (prop_disjoint_predicate @Int)-      it "within" $ property (prop_within_predicate @Int)-      it "enclose" $ property (prop_enclose_predicate @Int)-      it "enclosedBy" $ property (prop_enclosedBy_predicate @Int)-      it "notDisjoint" $ property (prop_notdisjoint_predicate @Int)-      it "concur" $ property (prop_concur_predicate @Int)+  describe "Interval Algebra relation properties for Interval Int"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @Int)+        it "starts" $ property (prop_IAstarts @Int)+        it "finishes" $ property (prop_IAfinishes @Int)+        it "overlaps" $ property (prop_IAoverlaps @Int)+        it "during" $ property (prop_IAduring @Int)+        it "disjoint" $ property (prop_disjoint_predicate @Int)+        it "within" $ property (prop_within_predicate @Int)+        it "enclose" $ property (prop_enclose_predicate @Int)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @Int)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @Int)+        it "concur" $ property (prop_concur_predicate @Int) -  describe "Interval Algebra relation properties for Interval Day" $-      modifyMaxSuccess (*100) $-    do-      it "before"   $ property (prop_IAbefore @Day)-      it "starts"   $ property (prop_IAstarts @Day)-      it "finishes" $ property (prop_IAfinishes @Day)-      it "overlaps" $ property (prop_IAoverlaps @Day)-      it "during"   $ property (prop_IAduring @Day)-      it "disjoint" $ property (prop_disjoint_predicate @Day)-      it "within" $ property (prop_within_predicate @Day)-      it "enclose" $ property (prop_enclose_predicate @Day)-      it "enclosedBy" $ property (prop_enclosedBy_predicate @Day)-      it "notDisjoint" $ property (prop_notdisjoint_predicate @Day)-      it "concur" $ property (prop_concur_predicate @Day)+  describe "Interval Algebra relation properties for Interval Day"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @Day)+        it "starts" $ property (prop_IAstarts @Day)+        it "finishes" $ property (prop_IAfinishes @Day)+        it "overlaps" $ property (prop_IAoverlaps @Day)+        it "during" $ property (prop_IAduring @Day)+        it "disjoint" $ property (prop_disjoint_predicate @Day)+        it "within" $ property (prop_within_predicate @Day)+        it "enclose" $ property (prop_enclose_predicate @Day)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @Day)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @Day)+        it "concur" $ property (prop_concur_predicate @Day) -  describe "Interval Algebra relation properties for Interval UTCTime" $-      modifyMaxSuccess (*100) $-    do-      it "before"   $ property (prop_IAbefore @UTCTime)-      it "starts"   $ property (prop_IAstarts @UTCTime)-      it "finishes" $ property (prop_IAfinishes @UTCTime)-      it "overlaps" $ property (prop_IAoverlaps @UTCTime)-      it "during"   $ property (prop_IAduring @UTCTime)-      it "disjoint" $ property (prop_disjoint_predicate @UTCTime)-      it "within" $ property (prop_within_predicate @UTCTime)-      it "enclose" $ property (prop_enclose_predicate @UTCTime)-      it "enclosedBy" $ property (prop_enclosedBy_predicate @UTCTime)-      it "notDisjoint" $ property (prop_notdisjoint_predicate @UTCTime)-      it "concur" $ property (prop_concur_predicate @UTCTime)+  describe "Interval Algebra relation properties for Interval UTCTime"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "before" $ property (prop_IAbefore @UTCTime)+        it "starts" $ property (prop_IAstarts @UTCTime)+        it "finishes" $ property (prop_IAfinishes @UTCTime)+        it "overlaps" $ property (prop_IAoverlaps @UTCTime)+        it "during" $ property (prop_IAduring @UTCTime)+        it "disjoint" $ property (prop_disjoint_predicate @UTCTime)+        it "within" $ property (prop_within_predicate @UTCTime)+        it "enclose" $ property (prop_enclose_predicate @UTCTime)+        it "enclosedBy" $ property (prop_enclosedBy_predicate @UTCTime)+        it "notDisjoint" $ property (prop_notdisjoint_predicate @UTCTime)+        it "concur" $ property (prop_concur_predicate @UTCTime) -  describe "Interval Algebra relation uniqueness" $-      modifyMaxSuccess (*100) $-    do-      it "exactly one relation must be true" $-        property (prop_exclusiveRelations @Int)-      it "exactly one relation must be true" $-        property (prop_exclusiveRelations @Day)-      it "exactly one relation must be true" $-        property (prop_exclusiveRelations @UTCTime)+  describe "Interval Algebra relation uniqueness"+    $ modifyMaxSuccess (* testScale)+    $ do+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @Int)+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @Day)+        it "exactly one relation must be true"+          $ property (prop_exclusiveRelations @UTCTime)

@@ -1,66 +1,112 @@+{- HLINT ignore -} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications  #-}-module IntervalAlgebra.IntervalUtilitiesSpec (spec) where -import           Control.Monad                     (liftM2)-import           Data.List                         (sort)-import           Data.Maybe                        (fromJust, isJust, isNothing)-import           Data.Set                          (Set, difference, fromList,-                                                    member, toList)-import qualified Data.Set                          (null)-import           Data.Time                         (Day, UTCTime)-import           IntervalAlgebra                   (Interval,-                                                    IntervalCombinable (..),-                                                    IntervalRelation (..),-                                                    IntervalSizeable,-                                                    Intervallic (..),-                                                    beginerval, complement,-                                                    converse, disjointRelations,-                                                    duration, intervalRelations,-                                                    moment', predicate, starts,-                                                    strictWithinRelations,-                                                    withinRelations)-import           IntervalAlgebra.Arbitrary         (arbitraryWithRelation)-import           IntervalAlgebra.IntervalUtilities (clip, combineIntervals,-                                                    durations, filterAfter,-                                                    filterBefore, filterConcur,-                                                    filterContains,-                                                    filterDisjoint,-                                                    filterDuring, filterEnclose,-                                                    filterEnclosedBy,-                                                    filterEquals,-                                                    filterFinishedBy,-                                                    filterFinishes, filterMeets,-                                                    filterMetBy,-                                                    filterNotDisjoint,-                                                    filterOverlappedBy,-                                                    filterOverlaps,-                                                    filterStartedBy,-                                                    filterStarts, filterWithin,-                                                    foldMeetingSafe,-                                                    formMeetingSequence, gaps,-                                                    gapsL, gapsWithin,-                                                    intersect, nothingIfAll,-                                                    nothingIfAny, nothingIfNone,-                                                    relationsL)-import           IntervalAlgebra.PairedInterval    (PairedInterval, getPairData,-                                                    makePairedInterval,-                                                    trivialize)-import           Test.Hspec                        (Spec, describe, it,-                                                    shouldBe)-import           Test.Hspec.QuickCheck             (modifyMaxDiscardRatio,-                                                    modifyMaxSuccess)-import           Test.QuickCheck                   (Arbitrary (arbitrary, shrink),-                                                    Arbitrary1 (liftArbitrary),-                                                    Property,-                                                    Testable (property),-                                                    elements, listOf,-                                                    orderedList, resize,-                                                    sublistOf, suchThat, (===),-                                                    (==>))-import           Witherable                        (Filterable) +module IntervalAlgebra.IntervalUtilitiesSpec+  ( spec+  ) where++import           Control.Monad                  ( liftM2 )+import           Data.List                      ( sort )+import           Data.Maybe                     ( fromJust+                                                , isJust+                                                , isNothing+                                                )+import           Data.Set                       ( Set+                                                , difference+                                                , fromList+                                                , member+                                                , toList+                                                )+import qualified Data.Set                       ( null )+import           Data.Time                      ( Day+                                                , UTCTime+                                                )+import           IntervalAlgebra                ( Interval+                                                , IntervalCombinable(..)+                                                , IntervalRelation(..)+                                                , IntervalSizeable+                                                , Intervallic(..)+                                                , beginerval+                                                , complement+                                                , converse+                                                , disjointRelations+                                                , duration+                                                , intervalRelations+                                                , moment'+                                                , predicate+                                                , safeInterval+                                                , starts+                                                , strictWithinRelations+                                                , withinRelations+                                                )+import           IntervalAlgebra.Arbitrary      ( arbitraryWithRelation )+import           IntervalAlgebra.IntervalUtilities+                                                ( clip+                                                , combineIntervals+                                                , durations+                                                , filterAfter+                                                , filterBefore+                                                , filterConcur+                                                , filterContains+                                                , filterDisjoint+                                                , filterDuring+                                                , filterEnclose+                                                , filterEnclosedBy+                                                , filterEquals+                                                , filterFinishedBy+                                                , filterFinishes+                                                , filterMeets+                                                , filterMetBy+                                                , filterNotDisjoint+                                                , filterOverlappedBy+                                                , filterOverlaps+                                                , filterStartedBy+                                                , filterStarts+                                                , filterWithin+                                                , foldMeetingSafe+                                                , formMeetingSequence+                                                , gaps+                                                , gapsL+                                                , gapsWithin+                                                , intersect+                                                , nothingIfAll+                                                , nothingIfAny+                                                , nothingIfNone+                                                , relationsL+                                                )+import           IntervalAlgebra.PairedInterval ( PairedInterval+                                                , getPairData+                                                , makePairedInterval+                                                , trivialize+                                                )+import           Test.Hspec                     ( Spec+                                                , describe+                                                , it+                                                , shouldBe+                                                )+import           Test.Hspec.QuickCheck          ( modifyMaxDiscardRatio+                                                , modifyMaxSuccess+                                                )+import           Test.QuickCheck                ( (===)+                                                , (==>)+                                                , Arbitrary(arbitrary, shrink)+                                                , Arbitrary1(liftArbitrary)+                                                , Property+                                                , Testable(property)+                                                , elements+                                                , listOf+                                                , orderedList+                                                , resize+                                                , sublistOf+                                                , suchThat+                                                )+import           Witherable                     ( Filterable )+++ -- Types for testing  -- SmallInterval is just to test properties for which events of interest are so@@ -70,7 +116,7 @@   deriving (Eq, Show)  instance Arbitrary SmallInterval where-   arbitrary = SmallInterval . beginerval 0 <$> elements [0..10]+  arbitrary = SmallInterval . beginerval 0 <$> elements [0 .. 10]  -- A "state" here is just used test formMeetingSequence newtype Events a@@ -82,12 +128,12 @@   deriving (Eq, Show)  instance Semigroup State where-     State x <> State y = State $ zipWith (||) x y+  State x <> State y = State $ zipWith (||) x y  instance Monoid State where-    mempty = State [False, False, False]+  mempty = State [False, False, False] -newtype StateEvent a = MkEvent { getEvent :: PairedInterval State a } +newtype StateEvent a = MkEvent { getEvent :: PairedInterval State a }    deriving (Eq, Ord, Show)  unEvents :: [StateEvent a] -> [PairedInterval State a]@@ -96,41 +142,40 @@ -- Type for checking arbitraryWithRelation -- A target and reference pair, where targetInterval satisfies at least one of -- refRelations relative to refInterval-data IntervalReferenced-  = IntervalReferenced-      { refInterval    :: Interval Int-      , refRelations   :: Set IntervalRelation-      , targetInterval :: Maybe (Interval Int)-      }+data IntervalReferenced = IntervalReferenced+  { refInterval    :: Interval Int+  , refRelations   :: Set IntervalRelation+  , targetInterval :: Maybe (Interval Int)+  }   deriving (Eq, Show) -readInterval :: IntervalSizeable a a => (a, a) -> Interval a-readInterval (b, e) = beginerval (e - b) b  mkEv :: IntervalSizeable a a => (a, a) -> b -> PairedInterval b a-mkEv i s = makePairedInterval s (readInterval i)+mkEv i s = makePairedInterval s (safeInterval i)  instance Arbitrary State where-   arbitrary =  State <$> suchThat (listOf arbitrary) (\x -> length x == 3)+  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 (StateEvent Int) where-   arbitrary = liftM2 (\x y -> MkEvent $ makePairedInterval x y) arbitrary (unSmall <$> arbitrary)+  arbitrary = liftM2 (\x y -> MkEvent $ makePairedInterval x y)+                     arbitrary+                     (unSmall <$> arbitrary)  instance Arbitrary (Events Int) where-   arbitrary = Events <$> orderedList+  arbitrary = Events <$> orderedList  -- restricted refIv to decrease rareness causing quickcheck to quit instance Arbitrary IntervalReferenced where-   arbitrary = do-      refIv <- liftM2 beginerval (elements [1..3]) (elements [0..3])-      rels <- fromList <$> sublistOf (toList intervalRelations)-      iv <- arbitraryWithRelation refIv rels-      return $ IntervalReferenced refIv rels iv+  arbitrary = do+    refIv <- liftM2 beginerval (elements [1 .. 3]) (elements [0 .. 3])+    rels  <- fromList <$> sublistOf (toList intervalRelations)+    iv    <- arbitraryWithRelation refIv rels+    pure $ IntervalReferenced refIv rels iv  -- Testing functions-checkSeqStates :: (Intervallic i Int)=> [i Int] -> Bool+checkSeqStates :: (Intervallic i Int) => [i Int] -> Bool checkSeqStates x = (length x > 1) || all (== Meets) (relationsL x)  -- Creation functions@@ -145,7 +190,7 @@ containmentInt = iv (10 :: Int) (0 :: Int)  noncontainmentInt :: Interval Int-noncontainmentInt = iv  6 4+noncontainmentInt = iv 6 4  anotherInt :: Interval Int anotherInt = iv 5 (15 :: Int)@@ -160,87 +205,80 @@ meets2 = [iv 2 0, iv 2 2, iv 10 4, iv 2 14]  meets3 :: [PairedInterval Int Int]-meets3 = map (uncurry makePairedInterval) [-      (5,  iv 2 0)-    , (5,  iv 2 2)-    , (9,  iv 10 4)-    , (10, iv 2 14)]+meets3 = map (uncurry makePairedInterval)+             [(5, iv 2 0), (5, iv 2 2), (9, iv 10 4), (10, iv 2 14)]  meets3eq :: [PairedInterval Int Int]-meets3eq = map (uncurry makePairedInterval) [-      (5,  iv 4 0)-    , (9,  iv 10 4)-    , (10, iv 2 14)]+meets3eq =+  map (uncurry makePairedInterval) [(5, iv 4 0), (9, iv 10 4), (10, iv 2 14)]  c0in :: [StateEvent Int] c0in =-  [ evpi 9 1  [True, False, False]-  , evpi 8 2  [True, False, False]-  , evpi 3 5  [False, True, False]-  , evpi 3 6  [False, True, False]]+  [ evpi 9 1 [True, False, False]+  , evpi 8 2 [True, False, False]+  , evpi 3 5 [False, True, False]+  , evpi 3 6 [False, True, False]+  ] c0out :: [StateEvent Int] c0out =-  [ evpi 4 1  [True, False, False]-  , evpi 4 5  [True, True, False]-  , evpi 1 9  [True, False, False]]+  [ evpi 4 1 [True, False, False]+  , evpi 4 5 [True, True, False]+  , evpi 1 9 [True, False, False]+  ]  c1in :: [StateEvent Int]-c1in =-  [ evpi 4 1  [True, False, False ]-  , evpi 4 6  [False, True, False ]]+c1in = [evpi 4 1 [True, False, False], evpi 4 6 [False, True, False]] c1out :: [StateEvent Int] c1out =-  [ evpi 4 1  [True, False, False]-  , evpi 1 5  [False, False, False]-  , evpi 4 6  [False, True, False]]+  [ evpi 4 1 [True, False, False]+  , evpi 1 5 [False, False, False]+  , evpi 4 6 [False, True, False]+  ]  c2in :: [StateEvent Int]-c2in =-  [ evpi 4 1  [True, False, False ]-  , evpi 5 5  [False, True, False ]]+c2in = [evpi 4 1 [True, False, False], evpi 5 5 [False, True, False]] c2out :: [StateEvent Int]-c2out =-  [ evpi 4 1  [True, False, False]-  , evpi 5 5  [False, True, False]]+c2out = [evpi 4 1 [True, False, False], evpi 5 5 [False, True, False]]  c3in :: [StateEvent Int]-c3in =-  [ evpi 4 1  [True, False, False ]-  , evpi 6 4  [False, True, False ]]+c3in = [evpi 4 1 [True, False, False], evpi 6 4 [False, True, False]] c3out :: [StateEvent Int] c3out =-  [ evpi 3 1  [True, False, False]-  , evpi 1 4  [True, True, False]-  , evpi 5 5  [False, True, False]]+  [ evpi 3 1 [True, False, False]+  , evpi 1 4 [True, True, False]+  , evpi 5 5 [False, True, False]+  ]  c4in :: [StateEvent Int] c4in =-  [ evpi 1 (-1)  [True, True, False ]-  , evpi 1 3     [True, False, True ]-  , evpi 1 3     [False, False, False]]+  [ evpi 1 (-1) [True, True, False]+  , evpi 1 3    [True, False, True]+  , evpi 1 3    [False, False, False]+  ] c4out :: [StateEvent Int] c4out =-  [ evpi 1 (-1)  [True, True, False ]-  , evpi 3 0     [False, False, False]-  , evpi 1 3     [True, False, True ]]+  [ evpi 1 (-1) [True, True, False]+  , evpi 3 0    [False, False, False]+  , evpi 1 3    [True, False, True]+  ]    c5in :: [PairedInterval State Int]-c5in = [-     mkEv (-63, 21) (State [False,True,True])-   , mkEv (-56, 20) (State [True,True,True])-   , mkEv (1, 41) (State [False,True,False])-   , mkEv (11, 34) (State [True,False,True])-   , mkEv (27, 28) (State [False,True,True])-   ]+c5in =+  [ mkEv (-63, 21) (State [False, True, True])+  , mkEv (-56, 20) (State [True, True, True])+  , mkEv (1  , 41) (State [False, True, False])+  , mkEv (11 , 34) (State [True, False, True])+  , mkEv (27 , 28) (State [False, True, True])+  ]  c5out :: [PairedInterval State Int]-c5out = [-     mkEv (-63, -56) (State [False,True,True])-   , mkEv (-56, 34) (State [True,True,True])-   , mkEv (34, 41) (State [False,True,False])-   ]+c5out =+  [ mkEv (-63, -56) (State [False, True, True])+  , mkEv (-56, 34)  (State [True, True, True])+  , mkEv (34 , 41)  (State [False, True, False])+  ]  -- Properties @@ -249,41 +287,36 @@ prop_withRelation_tautology :: IntervalReferenced -> Bool prop_withRelation_tautology ir   | isEnclose && isMom = isNothing iv-  | otherwise = isJust iv && predicate rels refIv (fromJust iv)-   where-      refIv = refInterval ir-      iv = targetInterval ir-      rels = refRelations ir-      isEnclose = Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations)-      isMom = duration refIv == moment' refIv+  | otherwise          = isJust iv && predicate rels refIv (fromJust iv)+ where+  refIv = refInterval ir+  iv    = targetInterval ir+  rels  = refRelations ir+  isEnclose =+    Data.Set.null $ Data.Set.difference rels (converse strictWithinRelations)+  isMom = duration refIv == moment' refIv   -- Check that the only relation remaining after applying a function is Before-prop_before:: (Ord a)=>-      ([Interval a] -> [Interval a])-   -> [Interval a]-   -> Property+prop_before+  :: (Ord a) => ([Interval a] -> [Interval a]) -> [Interval a] -> Property prop_before f x = relationsL ci === replicate (length ci - 1) Before-      where ci = f (sort x)+  where ci = f (sort x) -prop_combineIntervals1:: (Ord a, Show a, Eq a)=>-     [Interval a]-   -> Property+prop_combineIntervals1 :: (Ord a, Show a, Eq a) => [Interval a] -> Property prop_combineIntervals1 = prop_before combineIntervals -prop_gaps1:: (Ord a)=>-     [Interval a]-   -> Property+prop_gaps1 :: (Ord a) => [Interval a] -> Property prop_gaps1 = prop_before gapsL  -- In the case that that the input is not null, then -- * all relationsL should be `Meets` after formMeetingSequence-prop_formMeetingSequence0::-     Events Int-   -> Property+prop_formMeetingSequence0 :: Events Int -> Property prop_formMeetingSequence0 x =-   not (null es)  ==> all (== Meets) (relationsL $ formMeetingSequence (unEvents es)) === True-   where es = getEvents x+  not (null es)+    ==> all (== Meets) (relationsL $ formMeetingSequence (unEvents es))+    === True+  where es = getEvents x  -- In the case that the input has -- *     at least one Before relation between consequent pairs@@ -291,25 +324,26 @@ -- -- THEN the number empty states in the output should smaller than or equal to --      the number before relationsL in the output-prop_formMeetingSequence1::-     Events Int-   -> Property+prop_formMeetingSequence1 :: Events Int -> Property prop_formMeetingSequence1 x =-   ( beforeCount > 0 &&-     not (any (\x -> getPairData x == State [False, False, False]) (unEvents $ getEvents x))-   ) ==> beforeCount >= emptyCount-   where res = formMeetingSequence (unEvents $ getEvents x)-         beforeCount = lengthWhen (== Before) (relationsL (unEvents $ getEvents x))-         emptyCount  = lengthWhen (\x -> getPairData x == mempty ) res-         lengthWhen f = length . filter f+  (beforeCount > 0 && not+      (any (\x -> getPairData x == State [False, False, False])+           (unEvents $ getEvents x)+      )+    )+    ==> beforeCount+    >=  emptyCount+ where+  res         = formMeetingSequence (unEvents $ getEvents x)+  beforeCount = lengthWhen (== Before) (relationsL (unEvents $ getEvents x))+  emptyCount  = lengthWhen (\x -> getPairData x == mempty) res+  lengthWhen f = length . filter f  -- Check that formMeetingSequence doesn't return an empty list unless input is -- empty.-prop_formMeetingSequence2::-     Events Int-   -> Property+prop_formMeetingSequence2 :: Events Int -> Property prop_formMeetingSequence2 x = not (null $ getEvents x) ==> not $ null res-   where res = formMeetingSequence (unEvents $ getEvents x)+  where res = formMeetingSequence (unEvents $ getEvents x)  class ( Ord a ) => FiltrationProperties a  where    prop_filtration ::@@ -419,227 +453,246 @@  instance FiltrationProperties Int -prop_clip_intersect :: (Show a, Ord a, IntervalSizeable a b) =>-   Interval a -> Interval a -> Property-prop_clip_intersect x y =-   clip x y === intersect (min x y) (max x y)+prop_clip_intersect+  :: (Show a, Ord a, IntervalSizeable a b)+  => Interval a+  -> Interval a+  -> Property+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]+  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" $-    modifyMaxSuccess (*10) $-    do-      it "no gaps in containmentInt and noncontainmentInt" $-         gapsL [containmentInt, noncontainmentInt] `shouldBe` []-      it "no gaps in containmentInt" $-         gapsL [containmentInt] `shouldBe` []-      it "single gap between containmentInt and anotherInt" $-         gapsL [containmentInt, anotherInt] `shouldBe` [gapInt]-      it "after gaps, only relation should be Before" $-         property (prop_gaps1 @Int)+  describe "gaps tests" $ modifyMaxSuccess (* 10) $ do+    it "no gaps in containmentInt and noncontainmentInt"+      $          gapsL [containmentInt, noncontainmentInt]+      `shouldBe` []+    it "no gaps in containmentInt" $ gapsL [containmentInt] `shouldBe` []+    it "single gap between containmentInt and anotherInt"+      $          gapsL [containmentInt, anotherInt]+      `shouldBe` [gapInt]+    it "after gaps, only relation should be Before" $ property (prop_gaps1 @Int) -   describe "durations unit tests" $-      do-         it "durations of containmentInt is 10" $-            durations [containmentInt] `shouldBe` [10]-         it "durations of empty list is empty list" $-            durations  ([] :: [Interval Int])  `shouldBe` []-         it "durations of [containmentInt, anotherInt] is [10, 5]" $-            durations [containmentInt, anotherInt] `shouldBe` [10, 5]+  describe "durations unit tests" $ do+    it "durations of containmentInt is 10"+      $          durations [containmentInt]+      `shouldBe` [10]+    it "durations of empty list is empty list"+      $          durations ([] :: [Interval Int])+      `shouldBe` []+    it "durations of [containmentInt, anotherInt] is [10, 5]"+      $          durations [containmentInt, anotherInt]+      `shouldBe` [10, 5] -   describe "clip tests" $-      do-         it "clip disjoint should be Nothing" $-           clip containmentInt gapInt `shouldBe` Nothing-         it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)" $-           clip noncontainmentInt containmentInt `shouldBe`-             Just (iv 6 4)-         it "clip x y === intersect sort x y " $-            property (prop_clip_intersect @Int)+  describe "clip tests" $ do+    it "clip disjoint should be Nothing"+      $          clip containmentInt gapInt+      `shouldBe` Nothing+    it "clip Interval (4, 10) Interval (0, 10) should be Interval (4, 10)"+      $          clip noncontainmentInt containmentInt+      `shouldBe` Just (iv 6 4)+    it "clip x y === intersect sort x y " $ property (prop_clip_intersect @Int) -   describe "relationsL tests" $-         do-            it "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]" $-               relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt] `shouldBe`-                  [FinishedBy, Meets, Meets]-            it "relationsL of [] shouldBe []" $-               relationsL ([] :: [Interval Int]) `shouldBe` []-            it "relationsL of singleton shouldBe []" $-               relationsL [containmentInt] `shouldBe` []-            it "length of relationsL result should be 1 less then length of input" $-               property (\x  -> not (null x) ==> length (relationsL x) === length (x :: [Interval Int]) - 1 )+  describe "relationsL tests" $ do+    it+        "relationsL [(0, 10), (4, 10), (10, 15), (15, 20)] == [FinishedBy, Meets, Meets]"+      $ relationsL [containmentInt, noncontainmentInt, gapInt, anotherInt]+      `shouldBe` [FinishedBy, Meets, Meets]+    it "relationsL of [] shouldBe []"+      $          relationsL ([] :: [Interval Int])+      `shouldBe` []+    it "relationsL of singleton shouldBe []"+      $          relationsL [containmentInt]+      `shouldBe` []+    it "length of relationsL result should be 1 less then length of input"+      $ property+          (\x ->+            not (null x)+              ==> length (relationsL x)+              === length (x :: [Interval Int])+              -   1+          ) -   describe "gapsWithin tests" $-      do-         it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]" $-            gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12]-               `shouldBe` Just [iv 2 5, iv 1 9]-         it "gapsWithin (1, 10) [(-1, 0), (12,15)] should be [(5,7), (9,10)]" $-            gapsWithin (iv 9 1) [iv 1 (-1), iv 3 12]-               `shouldBe` Nothing-         it "gapsWithin (0, 455) [(0, 730), (731, 762), (763, 793)]" $-            gapsWithin (readInterval (0 :: Int, 455))-               (fmap readInterval [(0, 730), (731, 762), (763, 793)])-               `shouldBe` Just []-         it "gapsWithin (1, 10) [] should be []" $-             gapsWithin (iv 9 1) ([] :: [Interval a]) `shouldBe` Nothing+  describe "gapsWithin tests" $ do+    it "gapsWithin (1, 10) [(0,5), (7,9), (12,15)] should be [(5,7), (9,10)]"+      $          gapsWithin (iv 9 1) [iv 5 0, iv 2 7, iv 3 12]+      `shouldBe` Just [iv 2 5, iv 1 9]+    it "gapsWithin (1, 10) [(-1, 0), (12,15)] should be [(5,7), (9,10)]"+      $          gapsWithin (iv 9 1) [iv 1 (-1), iv 3 12]+      `shouldBe` Nothing+    it "gapsWithin (0, 455) [(0, 730), (731, 762), (763, 793)]"+      $ gapsWithin (safeInterval (0 :: Int, 455))+                   (fmap safeInterval [(0, 730), (731, 762), (763, 793)])+      `shouldBe` Just []+    it "gapsWithin (1, 10) [] should be []"+      $          gapsWithin (iv 9 1) ([] :: [Interval a])+      `shouldBe` Nothing -   describe "emptyIf tests" $-      do-         it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty" $-            nothingIfNone (starts (iv 2 3)) [iv 1 3, iv 1 5]-               `shouldBe` Nothing-         it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input" $-            nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5]-               `shouldBe` Just [ iv 3 3, iv 1 5]+  describe "emptyIf tests" $ do+    it "emptyIfNone (starts (3, 5)) [(3,4), (5,6)] should be empty"+      $          nothingIfNone (starts (iv 2 3)) [iv 1 3, iv 1 5]+      `shouldBe` Nothing+    it "emptyIfNone (starts (3, 5)) [(3,6), (5,6)] shoiuld be input"+      $          nothingIfNone (starts (iv 2 3)) [iv 3 3, iv 1 5]+      `shouldBe` Just [iv 3 3, iv 1 5] -   describe "filtration tests" $-      modifyMaxDiscardRatio (*2) $-      do-         it "disjoint filter should filter out noncontainment" $-            filterDisjoint containmentInt [noncontainmentInt, anotherInt]-               `shouldBe` [anotherInt]-         it "notDisjoint filter should keep noncontainment" $-            filterNotDisjoint containmentInt [noncontainmentInt, anotherInt]-               `shouldBe` [noncontainmentInt]-         it "filterBefore property" $ property (prop_filterBefore @Int)-         it "filterAfter property" $ property (prop_filterAfter @Int)-         it "filterOverlaps property" $ property (prop_filterOverlaps @Int)-         it "filterOverlappedBy property" $ property (prop_filterOverlappedBy @Int)-         it "filterStarts property" $ property (prop_filterStarts @Int)-         it "filterStartedBy property" $ property (prop_filterStartedBy @Int)-         it "filterFinishes property" $ property (prop_filterFinishes @Int)-         it "filterFinishedBy property" $ property (prop_filterFinishedBy @Int)-         it "filterMeets property" $ property (prop_filterMeets @Int)-         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_small_filterEquals-         it "filterDisjoint property" $ property (prop_filterDisjoint @Int)-         it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int)-         it "filterWithin property" $ property (prop_filterWithin @Int)-         it "filterConcur property" $ property (prop_filterConcur @Int)-         it "filterEnclose property" $ property (prop_filterEnclose @Int)-         it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int)+  describe "filtration tests" $ modifyMaxDiscardRatio (* 2) $ do+    it "disjoint filter should filter out noncontainment"+      $          filterDisjoint containmentInt [noncontainmentInt, anotherInt]+      `shouldBe` [anotherInt]+    it "notDisjoint filter should keep noncontainment"+      $ filterNotDisjoint containmentInt [noncontainmentInt, anotherInt]+      `shouldBe` [noncontainmentInt]+    it "filterBefore property" $ property (prop_filterBefore @Int)+    it "filterAfter property" $ property (prop_filterAfter @Int)+    it "filterOverlaps property" $ property (prop_filterOverlaps @Int)+    it "filterOverlappedBy property" $ property (prop_filterOverlappedBy @Int)+    it "filterStarts property" $ property (prop_filterStarts @Int)+    it "filterStartedBy property" $ property (prop_filterStartedBy @Int)+    it "filterFinishes property" $ property (prop_filterFinishes @Int)+    it "filterFinishedBy property" $ property (prop_filterFinishedBy @Int)+    it "filterMeets property" $ property (prop_filterMeets @Int)+    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_small_filterEquals+    it "filterDisjoint property" $ property (prop_filterDisjoint @Int)+    it "filterNotDisjoint property" $ property (prop_filterNotDisjoint @Int)+    it "filterWithin property" $ property (prop_filterWithin @Int)+    it "filterConcur property" $ property (prop_filterConcur @Int)+    it "filterEnclose property" $ property (prop_filterEnclose @Int)+    it "filterEnclosedBy property" $ property (prop_filterEnclosedBy @Int) -   describe "nothingIf unit tests" $-     do-        it "nothing from nothingIfAll" $-         nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3] `shouldBe` Nothing-        it "something from nothingIfAll" $-         nothingIfAll (starts (iv 2 3)) [iv 3 0, iv 4 3] `shouldBe` Just [iv 3 0, iv 4 3]-        it "nothing from nothingIfAny" $-         nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5] `shouldBe` Nothing-        it "something from nothingIfAny" $-         nothingIfAny (starts (iv 2 3)) [iv 3 1, iv 1 5] `shouldBe` Just [iv 3 1, iv 1 5]+  describe "nothingIf unit tests" $ do+    it "nothing from nothingIfAll"+      $          nothingIfAll (starts (iv 2 3)) [iv 3 3, iv 4 3]+      `shouldBe` Nothing+    it "something from nothingIfAll"+      $          nothingIfAll (starts (iv 2 3)) [iv 3 0, iv 4 3]+      `shouldBe` Just [iv 3 0, iv 4 3]+    it "nothing from nothingIfAny"+      $          nothingIfAny (starts (iv 2 3)) [iv 3 3, iv 1 5]+      `shouldBe` Nothing+    it "something from nothingIfAny"+      $          nothingIfAny (starts (iv 2 3)) [iv 3 1, iv 1 5]+      `shouldBe` Just [iv 3 1, iv 1 5] -   describe "intersection tests" $-      do-         it "intersection of (0, 2) (2, 4) should be Nothing" $-            intersect (iv 2 0) (iv 2 2)    `shouldBe` Nothing-         it "intersection of (0, 2) (3, 4) should be Nothing" $-            intersect (iv 2 0) (iv 1 3)    `shouldBe` Nothing-         it "intersection of (2, 4) (0, 2) should be Nothing" $-            intersect (iv 2 2) (iv 2 0)    `shouldBe` Nothing+  describe "intersection tests" $ do+    it "intersection of (0, 2) (2, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 2 2)+      `shouldBe` Nothing+    it "intersection of (0, 2) (3, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 1 3)+      `shouldBe` Nothing+    it "intersection of (2, 4) (0, 2) should be Nothing"+      $          intersect (iv 2 2) (iv 2 0)+      `shouldBe` Nothing -   describe "intersection tests" $-      do-         it "intersection of (0, 2) (2, 4) should be Nothing" $-            intersect (iv 2 0) (iv 2 2)    `shouldBe` Nothing-         it "intersection of (0, 2) (3, 4) should be Nothing" $-            intersect (iv 2 0) (iv 1 3)    `shouldBe` Nothing-         it "intersection of (2, 4) (0, 2) should be Nothing" $-            intersect (iv 2 2) (iv 2 0)    `shouldBe` Nothing-         it "intersection of (0, 2) (1, 3) should be Just (1, 2)" $-            intersect (iv 2 0) (iv 2 1)    `shouldBe` Just (iv 1 1)-         it "intersection of (0, 2) (-1, 3) should be Just (0, 2)" $-            intersect (iv 2 0) (iv 4 (-1)) `shouldBe` Just (iv 2 0)-         it "intersection of (0, 2) (0, 2) should be Just (0, 2)" $-            intersect (iv 2 0) (iv 2 0)    `shouldBe` Just (iv 2 0)-         it "intersection of (0, 2) (-1, 1) should be Just (0, 1)" $-            intersect (iv 2 0) (iv 2 (-1)) `shouldBe` Just (iv 1 0)-         it "intersection of (0, 3) (1, 2) should be Just (1, 2)" $-            intersect (iv 3 0) (iv 1 1)    `shouldBe` Just (iv 1 1)+  describe "intersection tests" $ do+    it "intersection of (0, 2) (2, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 2 2)+      `shouldBe` Nothing+    it "intersection of (0, 2) (3, 4) should be Nothing"+      $          intersect (iv 2 0) (iv 1 3)+      `shouldBe` Nothing+    it "intersection of (2, 4) (0, 2) should be Nothing"+      $          intersect (iv 2 2) (iv 2 0)+      `shouldBe` Nothing+    it "intersection of (0, 2) (1, 3) should be Just (1, 2)"+      $          intersect (iv 2 0) (iv 2 1)+      `shouldBe` Just (iv 1 1)+    it "intersection of (0, 2) (-1, 3) should be Just (0, 2)"+      $          intersect (iv 2 0) (iv 4 (-1))+      `shouldBe` Just (iv 2 0)+    it "intersection of (0, 2) (0, 2) should be Just (0, 2)"+      $          intersect (iv 2 0) (iv 2 0)+      `shouldBe` Just (iv 2 0)+    it "intersection of (0, 2) (-1, 1) should be Just (0, 1)"+      $          intersect (iv 2 0) (iv 2 (-1))+      `shouldBe` Just (iv 1 0)+    it "intersection of (0, 3) (1, 2) should be Just (1, 2)"+      $          intersect (iv 3 0) (iv 1 1)+      `shouldBe` Just (iv 1 1) -   describe "combineIntervals unit tests" $-      do-         it "noncontainmentInt combined into containmentInt" $-               combineIntervals [containmentInt, noncontainmentInt]-                  `shouldBe` [containmentInt]-         it "noncontainmentInt combined into containmentInt; anotherInt unchanged" $-               combineIntervals [containmentInt, noncontainmentInt, anotherInt]-                  `shouldBe` [containmentInt, anotherInt]-         it "idempotency of containmentInt" $-               combineIntervals [containmentInt] `shouldBe` [containmentInt]-         it "idempotency of noncontainmentInt" $-               combineIntervals [noncontainmentInt] `shouldBe` [noncontainmentInt]-         it "combineIntervals [] should be []" $-               combineIntervals ([] :: [Interval Int]) `shouldBe` []-         it "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]" $-               combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]-                  `shouldBe` [iv 12 0, iv 2 13]+  describe "combineIntervals unit tests" $ do+    it "noncontainmentInt combined into containmentInt"+      $          combineIntervals [containmentInt, noncontainmentInt]+      `shouldBe` [containmentInt]+    it "noncontainmentInt combined into containmentInt; anotherInt unchanged"+      $ combineIntervals [containmentInt, noncontainmentInt, anotherInt]+      `shouldBe` [containmentInt, anotherInt]+    it "idempotency of containmentInt"+      $          combineIntervals [containmentInt]+      `shouldBe` [containmentInt]+    it "idempotency of noncontainmentInt"+      $          combineIntervals [noncontainmentInt]+      `shouldBe` [noncontainmentInt]+    it "combineIntervals [] should be []"+      $          combineIntervals ([] :: [Interval Int])+      `shouldBe` []+    it "combineIntervals [(0, 10), (2, 7), (10, 12), (13, 15)]"+      $          combineIntervals [iv 10 0, iv 5 2, iv 2 10, iv 2 13]+      `shouldBe` [iv 12 0, iv 2 13] -   describe "combineIntervals property tests" $-      modifyMaxSuccess (*10) $-      do-         it "after combining, only relation should be Before" $-               property ( prop_combineIntervals1 @Int)-         it "after combining, only relation should be Before" $-               property ( prop_combineIntervals1 @Day)-         it "after combining, only relation should be Before" $-               property ( prop_combineIntervals1 @UTCTime)+  describe "combineIntervals property tests" $ modifyMaxSuccess (* 10) $ do+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @Int)+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @Day)+    it "after combining, only relation should be Before"+      $ property (prop_combineIntervals1 @UTCTime) -   describe "foldMeets unit tests" $-      do-         it "foldMeetingSafe meets1" $-               foldMeetingSafe (trivialize meets1) `shouldBe`-                  trivialize [iv 4 0]-         it "foldMeetingSafe meets2" $-               foldMeetingSafe (trivialize meets2) `shouldBe`-                  trivialize [iv 16 0]-         it "foldMeetingSafe meets3" $-               foldMeetingSafe meets3 `shouldBe` meets3eq+  describe "foldMeets unit tests" $ do+    it "foldMeetingSafe meets1"+      $          foldMeetingSafe (trivialize meets1)+      `shouldBe` trivialize [iv 4 0]+    it "foldMeetingSafe meets2"+      $          foldMeetingSafe (trivialize meets2)+      `shouldBe` trivialize [iv 16 0]+    it "foldMeetingSafe meets3" $ foldMeetingSafe meets3 `shouldBe` meets3eq -   describe "formMeetingSequence unit tests" $-      do-         it "formMeetingSequence unit test 0" $-            formMeetingSequence (unEvents c0in) `shouldBe` unEvents c0out-         it "formMeetingSequence unit test 1"$-            formMeetingSequence (unEvents c1in) `shouldBe` unEvents c1out-         it "formMeetingSequence unit test 2"$-            formMeetingSequence (unEvents c2in) `shouldBe` unEvents c2out-         it "formMeetingSequence unit test 3"$-            formMeetingSequence (unEvents c3in) `shouldBe` unEvents c3out-         it "formMeetingSequence unit test 4"$-            formMeetingSequence (unEvents c4in) `shouldBe` unEvents c4out-         it "formMeetingSequence unit test 5"$-            formMeetingSequence c5in `shouldBe` c5out-         it "formMeetingSequence unit test 6"$-            formMeetingSequence ([] :: [PairedInterval State Int]) `shouldBe` []+  describe "formMeetingSequence unit tests" $ do+    it "formMeetingSequence unit test 0"+      $          formMeetingSequence (unEvents c0in)+      `shouldBe` unEvents c0out+    it "formMeetingSequence unit test 1"+      $          formMeetingSequence (unEvents c1in)+      `shouldBe` unEvents c1out+    it "formMeetingSequence unit test 2"+      $          formMeetingSequence (unEvents c2in)+      `shouldBe` unEvents c2out+    it "formMeetingSequence unit test 3"+      $          formMeetingSequence (unEvents c3in)+      `shouldBe` unEvents c3out+    it "formMeetingSequence unit test 4"+      $          formMeetingSequence (unEvents c4in)+      `shouldBe` unEvents c4out+    it "formMeetingSequence unit test 5"+      $          formMeetingSequence c5in+      `shouldBe` c5out+    it "formMeetingSequence unit test 6"+      $          formMeetingSequence ([] :: [PairedInterval State Int])+      `shouldBe` [] -   describe "formMeetingSequence property tests" $-      modifyMaxSuccess (*50) $-      do-          it "prop_formMeetingSequence0" $-            property prop_formMeetingSequence0-          it "prop_formMeetingSequence1" $-            property prop_formMeetingSequence1-          it "prop_formMeetingSequence2" $-            property prop_formMeetingSequence2+  describe "formMeetingSequence property tests" $ modifyMaxSuccess (* 2) $ do+    it "prop_formMeetingSequence0" $ property prop_formMeetingSequence0+     -- 2022-05-18 - BS+    -- Commmenting out this test as the execution of the test suite blows up+    -- when this property check is included.+    -- TODO: consider whether this check is worthwhile.+    -- it "prop_formMeetingSequence1" $ property prop_formMeetingSequence1+    it "prop_formMeetingSequence2" $ property prop_formMeetingSequence2 -   describe "arbitraryWithRelation property tests" $-      do-          it "prop_withRelation_tautology" $-             property prop_withRelation_tautology+  -- describe "arbitraryWithRelation property tests" $ do+  --   it "prop_withRelation_tautology" $ property prop_withRelation_tautology

@@ -1,19 +1,28 @@-module IntervalAlgebra.PairedIntervalSpec (spec) where+module IntervalAlgebra.PairedIntervalSpec+  ( spec+  ) where -import Test.Hspec                       ( it, describe, Spec, shouldBe )-import IntervalAlgebra.PairedInterval   ( PairedInterval-                                        , makePairedInterval-                                        , intervals-                                        , Empty(..) )-import IntervalAlgebra                  ( beginerval-                                        , IntervalSizeable(duration)-                                        , equals-                                        , before-                                        , IntervalCombinable(..) )-import Data.Bifunctor                   ( Bifunctor(bimap) )-import Data.Bool-import Data.Time                        ( Day(ModifiedJulianDay)-                                        , fromGregorian )+import           Data.Bifunctor                 ( Bifunctor(bimap) )+import           Data.Bool+import           Data.Time                      ( Day(ModifiedJulianDay)+                                                , fromGregorian+                                                )+import           IntervalAlgebra                ( IntervalCombinable(..)+                                                , IntervalSizeable(duration)+                                                , before+                                                , beginerval+                                                , equals+                                                )+import           IntervalAlgebra.PairedInterval ( Empty(..)+                                                , PairedInterval+                                                , intervals+                                                , makePairedInterval+                                                )+import           Test.Hspec                     ( Spec+                                                , describe+                                                , it+                                                , shouldBe+                                                )  type TestPair = PairedInterval String Int @@ -31,45 +40,42 @@  spec :: Spec spec = do-  describe "Basic tests of paired intervals" $-    do -    it "the same pairInterval should be equal" $ t1 == t1 `shouldBe` True +  describe "Basic tests of paired intervals" $ do+    it "the same pairInterval should be equal" $ t1 == t1 `shouldBe` True     it "different pairInterval should not be equal" $ t1 /= t2 `shouldBe` True-    it "fmapping into a different interval type" $ -        fmap ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0))-            `shouldBe` makePairedInterval "hi" (beginerval 5 (fromGregorian 1858 11 17)) -    it "bimapping into a different type" $ -        bimap (== "hi") ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0))-            `shouldBe `makePairedInterval True (beginerval 5 (fromGregorian 1858 11 17))-    it "show paired interval" $-      show t1 `shouldBe` "{(0, 5), \"hi\"}"+    it "fmapping into a different interval type"+      $ fmap ModifiedJulianDay (makePairedInterval "hi" (beginerval 5 0))+      `shouldBe` makePairedInterval "hi"+                                    (beginerval 5 (fromGregorian 1858 11 17))+    it "bimapping into a different type"+      $          bimap (== "hi")+                       ModifiedJulianDay+                       (makePairedInterval "hi" (beginerval 5 0))+      `shouldBe` makePairedInterval True+                                    (beginerval 5 (fromGregorian 1858 11 17))+    it "show paired interval" $ show t1 `shouldBe` "{(0, 5), \"hi\"}" -    describe "tests on paired intervals" $-        do -            it "t1 is before t2" $-                (t1 `before` t2) `shouldBe` True-            it "duration of t1 is 5" $-                duration t1 `shouldBe` 5-            it "t1 is equal to t3" $-                 (t1 `equals` t3) `shouldBe` True-            it "t1 is LT t2" $-                 (t1 < t2) `shouldBe` True-            it "getintervals [t1, t2, t3]" $-                intervals [t1, t2, t3] `shouldBe`-                 [beginerval 5 0, beginerval 4 6, beginerval 5 0]-    -    describe "IntervalCombinable tests" $-      do -        it "" $ (t1 >< t3) `shouldBe` Nothing-        it "" $ (t1 >< mkTestPr "hello" 1 6) `shouldBe` Just (mkTestPr "" 1 5)-        it "" $ (t1 <+> mkTestPr "hello" 1 6) `shouldBe` [t1, mkTestPr "hello" 1 6]-        it "" $ (t1 <+> mkTestPr "hello" 5 3) `shouldBe` [mkTestPr "hihello" 8 0]-    -    describe "tests on empty" $-      do -        it "show empty" $ show Empty `shouldBe` "Empty"-        it "combine emptyies" $ Empty <> Empty `shouldBe` Empty -        it "monoid empty" $ (mempty :: Empty) `shouldBe` Empty-        it "monoid mappend" $ mappend Empty Empty `shouldBe` Empty -        it "ord empty" $ Empty < Empty `shouldBe` False-        it "ord empty" $ Empty <= Empty `shouldBe` True+    describe "tests on paired intervals" $ do+      it "t1 is before t2" $ (t1 `before` t2) `shouldBe` True+      it "duration of t1 is 5" $ duration t1 `shouldBe` 5+      it "t1 is equal to t3" $ (t1 `equals` t3) `shouldBe` True+      it "t1 is LT t2" $ (t1 < t2) `shouldBe` True+      it "getintervals [t1, t2, t3]"+        $          intervals [t1, t2, t3]+        `shouldBe` [beginerval 5 0, beginerval 4 6, beginerval 5 0]++    describe "IntervalCombinable tests" $ do+      it "" $ (t1 >< t3) `shouldBe` Nothing+      it "" $ (t1 >< mkTestPr "hello" 1 6) `shouldBe` Just (mkTestPr "" 1 5)+      it ""+        $          (t1 <+> mkTestPr "hello" 1 6)+        `shouldBe` [t1, mkTestPr "hello" 1 6]+      it "" $ (t1 <+> mkTestPr "hello" 5 3) `shouldBe` [mkTestPr "hihello" 8 0]++    describe "tests on empty" $ do+      it "show empty" $ show Empty `shouldBe` "Empty"+      it "combine emptyies" $ Empty <> Empty `shouldBe` Empty+      it "monoid empty" $ (mempty :: Empty) `shouldBe` Empty+      it "monoid mappend" $ mappend Empty Empty `shouldBe` Empty+      it "ord empty" $ Empty < Empty `shouldBe` False+      it "ord empty" $ Empty <= Empty `shouldBe` True

@@ -2,283 +2,335 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}-module IntervalAlgebraSpec (spec) where+module IntervalAlgebraSpec+  ( spec+  ) where -import Test.Hspec                 ( hspec, describe, it, Spec, shouldBe )-import Test.Hspec.QuickCheck      ( modifyMaxSuccess, modifyMaxDiscardRatio )-import Test.QuickCheck            ( (===)-                                  , (==>)-                                  , quickCheck-                                  , generate-                                  , Gen(..)-                                  , Arbitrary(arbitrary)-                                  , Property-                                  , Testable(property) )-import GHC.Real                   ( Rational(..), Real(..) )-import Data.Maybe                 ( fromJust, isJust, isNothing )-import Data.Either                ( isRight )-import Data.Fixed                 ( Pico )-import IntervalAlgebra.Arbitrary  ()-import Data.Time as DT            ( Day(..)-                                  , UTCTime(..)-                                  , DiffTime-                                  , fromGregorian-                                  , secondsToDiffTime-                                  , picosecondsToDiffTime, NominalDiffTime-                                  )-import Data.Set                   ( Set-                                  , member-                                  , disjointUnion-                                  , fromList )-import IntervalAlgebra as IA      +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      ( )+import           Test.Hspec                     ( Spec+                                                , describe+                                                , hspec+                                                , it+                                                , shouldBe+                                                )+import           Test.Hspec.QuickCheck          ( modifyMaxDiscardRatio+                                                , modifyMaxSuccess+                                                )+import           Test.QuickCheck                ( (===)+                                                , (==>)+                                                , Arbitrary(arbitrary)+                                                , Gen(..)+                                                , Property+                                                , Testable(property)+                                                , generate+                                                , quickCheck+                                                )  mkIntrvl :: Int -> Int -> Interval Int mkIntrvl = beginerval -prop_expandl_end ::(IntervalSizeable a b, Show a)=>-       b-    -> Interval a-    -> Property+prop_expandl_end+  :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property prop_expandl_end d i = end (expandl d i) === end i  -prop_expandr_begin ::(IntervalSizeable a b, Show a)=>-       b-    -> Interval a-    -> Property+prop_expandr_begin+  :: (IntervalSizeable a b, Show a) => b -> 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 =>-       Interval a-    -> Interval a-    -> Interval a-    -> Property-prop_compose x y z = member (relate x z) (compose (relate x y) (relate y z)) === True+prop_compose :: Ord 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 => -     Interval a-  -> Interval a-  -> Property -prop_combinable_gap_exists x y = -  (before <|> after) x y ==> isJust (uncurry (><) (min x y, max x y))+prop_combinable_gap_exists :: Ord 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 => -     Interval a-  -> Interval a-  -> Property -prop_combinable_nogap_exists x y = -  (predicate $ complement $ fromList [Before, After]) x y ==> -    isNothing (uncurry (><) (min x y, max x y))+prop_combinable_nogap_exists :: Ord 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))   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+  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" $ moment' (beginervalMoment (-13::Int)) `shouldBe` (1 :: Int)-      it "endervalMoment duration is moment" $ moment' (endervalMoment (26::Int)) `shouldBe` (1 :: Int)+    it "beginervalMoment duration is moment"+      $          moment' (beginervalMoment (-13 :: Int))+      `shouldBe` (1 :: Int)+    it "endervalMoment duration is moment"+      $          moment' (endervalMoment (26 :: Int))+      `shouldBe` (1 :: 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 "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)"+    it "show displays intervals as expected"+      $          show (beginerval 10 (0 :: Int))+      `shouldBe` "(0, 10)" -      it "fmap can convert Interval Integer to Interval Day" $-         fmap ModifiedJulianDay (beginerval 1 0) `shouldBe`-            beginerval 1 (fromGregorian 1858 11 17)+    it "fmap can convert Interval Integer to Interval Day"+      $          fmap ModifiedJulianDay (beginerval 1 0)+      `shouldBe` beginerval 1 (fromGregorian 1858 11 17) -      it "(0, 2) <= (1, 3) is True" $-          beginerval 2 (0::Int) <= beginerval 2 1 `shouldBe` True+    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+    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+  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 "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"+    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 "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]+  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 []+    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 "IntervalSizeable tests" $-    do-      it "moment is 1" $ moment @Int `shouldBe` 1-      it "moment' is 1" $ moment' (beginerval 1 (0::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 @Int) 0 (beginerval (1::Int) (0::Int)) `shouldBe`-         beginerval (2::Int) (-1::Int)+  describe "IntervalSizeable tests" $ do+    it "moment is 1" $ moment @Int `shouldBe` 1+    it "moment' is 1" $ moment' (beginerval 1 (0 :: 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 @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 "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 "diffFromBegin can convert Interval Int to Interval Int" $-         diffFromBegin -            (beginerval 2 (4 :: Int))-            (beginerval 2 10) `shouldBe`-            beginerval 2 6 -- (6, 8)+    it "diffFromBegin can convert Interval Int to Interval Int"+      $          diffFromBegin (beginerval 2 (4 :: Int)) (beginerval 2 10)+      `shouldBe` beginerval 2 6 -- (6, 8) -      it "diffFromEnd can convert Interval Int to Interval Int" $-         diffFromEnd-            (beginerval 2 (4 :: Int))-            (beginerval 2 10) `shouldBe`-            beginerval 2 4 -- (4, 6)+    it "diffFromEnd can convert Interval Int to Interval Int"+      $          diffFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10)+      `shouldBe` beginerval 2 4 -- (4, 6) -      it "diffFromBegin can convert Interval Day to Interval Integer" $-         diffFromBegin -            (beginerval 2 (fromGregorian 2001 1 1))-            (beginerval 2 (fromGregorian 2001 1 10)) `shouldBe`-            beginerval 2 9 -- (9, 11)+    it "diffFromBegin can convert Interval Day to Interval Integer"+      $          diffFromBegin (beginerval 2 (fromGregorian 2001 1 1))+                               (beginerval 2 (fromGregorian 2001 1 10))+      `shouldBe` beginerval 2 9 -- (9, 11) -      it "diffFromEnd can convert Interval Day to Interval Integer" $-         diffFromEnd-            (beginerval 2 (fromGregorian 2001 1 1))-            (beginerval 2 (fromGregorian 2001 1 10)) `shouldBe`-            beginerval 2 7 -- (7, 9)+    it "diffFromEnd can convert Interval Day to Interval Integer"+      $          diffFromEnd (beginerval 2 (fromGregorian 2001 1 1))+                             (beginerval 2 (fromGregorian 2001 1 10))+      `shouldBe` beginerval 2 7 -- (7, 9) -      it "momentize works" $-         momentize-            (beginerval 2 (fromGregorian 2001 1 1))-            `shouldBe`-            beginerval 1 (fromGregorian 2001 1 1)+    it "momentize works"+      $          momentize (beginerval 2 (fromGregorian 2001 1 1))+      `shouldBe` beginerval 1 (fromGregorian 2001 1 1)     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)+                                 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 "IntervalCombinable 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)+  describe "IntervalCombinable 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 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) +    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)) +  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))