diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for interval-algebra +## 2.1.2 + +* Exports `IntervalAlgebra.IntervalDiagram` module and makes the following changes so as to export it as `safe`: + * Removes `nonempty-containers` dependency and `Data.IntMap.NonEmpty` usage in `IntervalAlgebra.IntervalDiagram`. Replaces the non-empty `IntMap` with a key-value pair in a non-empty list. + * Removes `From` instances, which were unnecessary. + ## 2.1.1 * Makes the version bounds on the `time` package diff --git a/interval-algebra.cabal b/interval-algebra.cabal --- a/interval-algebra.cabal +++ b/interval-algebra.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: interval-algebra -version: 2.1.1 +version: 2.1.2 synopsis: An implementation of Allen's interval algebra for temporal logic description: Please see the README on GitHub at category: Algebra,Time @@ -42,7 +42,6 @@ , containers ^>= 0.6 , deepseq >= 1.1 && < 1.5 , foldl ^>= 1.4 - , nonempty-containers ^>= 0.3 , prettyprinter ^>= 1.7 , QuickCheck ^>= 2.14 , safe ^>= 0.3 diff --git a/src/IntervalAlgebra.hs b/src/IntervalAlgebra.hs --- a/src/IntervalAlgebra.hs +++ b/src/IntervalAlgebra.hs @@ -5,9 +5,9 @@ License : BSD3 Maintainer : bsaul@novisci.com -The @IntervalAlgebra@ module provides data types and related classes for the +The @IntervalAlgebra@ module provides data types and related classes for the interval-based temporal logic described in [Allen (1983)](https://doi.org/10.1145/182.358434) -and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). +and axiomatized in [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). A good primer on Allen's algebra can be [found here](https://thomasalspaugh.org/pub/fnd/allen.html). This main module reexports @IntervalAlgebra.Core@, @IntervalAlgebra.IntervalUtilities@, @@ -23,6 +23,7 @@ , module IntervalAlgebra.PairedInterval ) where -import safe IntervalAlgebra.Core -import safe IntervalAlgebra.IntervalUtilities -import safe IntervalAlgebra.PairedInterval +import safe IntervalAlgebra.Core +import safe IntervalAlgebra.IntervalDiagram +import safe IntervalAlgebra.IntervalUtilities +import safe IntervalAlgebra.PairedInterval diff --git a/src/IntervalAlgebra/Arbitrary.hs b/src/IntervalAlgebra/Arbitrary.hs --- a/src/IntervalAlgebra/Arbitrary.hs +++ b/src/IntervalAlgebra/Arbitrary.hs @@ -6,74 +6,45 @@ Maintainer : bsaul@novisci.com Stability : experimental -} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} 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(..) - , 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 - ) +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 diff --git a/src/IntervalAlgebra/Axioms.hs b/src/IntervalAlgebra/Axioms.hs --- a/src/IntervalAlgebra/Axioms.hs +++ b/src/IntervalAlgebra/Axioms.hs @@ -6,7 +6,7 @@ License : BSD3 Maintainer : bsaul@novisci.com -This module exports a single typeclass @IntervalAxioms@ which contains +This module exports a single typeclass @IntervalAxioms@ which contains property-based tests for the axioms in section 1 of [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). The notation below is that of the original paper. @@ -14,7 +14,7 @@ -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,29 +25,16 @@ , 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 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 - ) +import Test.QuickCheck (Arbitrary (arbitrary), Property, + (===), (==>)) xor :: Bool -> Bool -> Bool @@ -161,12 +148,12 @@ == Axiom M1 The first axiom of Allen and Hayes (1987) states that if "two periods both - meet a third, thn any period met by one must also be met by the other." + meet a third, thn any period met by one must also be met by the other." That is: \[ \forall \text{ i,j,k,l } s.t. (i:j \text{ & } i:k \text{ & } l:j) \implies l:k - \] + \] -} prop_IAaxiomM1 :: (Ord a) => M1set a -> Property prop_IAaxiomM1 x = @@ -188,21 +175,21 @@ == Axiom M2 - If period i meets period j and period k meets l, + If period i meets period j and period k meets l, then exactly one of the following holds: - 1) i meets l; - 2) there is an m such that i meets m and m meets l; + 1) i meets l; + 2) there is an m such that i meets m and m meets l; 3) there is an n such that k meets n and n meets j. - + That is, \[ - \forall i,j,k,l s.t. (i:j \text { & } k:l) \implies - i:l \oplus + \forall i,j,k,l s.t. (i:j \text { & } k:l) \implies + i:l \oplus (\exists m s.t. i:m:l) \oplus - (\exists m s.t. k:m:j) - \] + (\exists m s.t. k:m:j) + \] -} @@ -228,7 +215,7 @@ \[ \forall i \lnot i:i - \] + \] -} prop_IAaxiomML1 :: (Ord a) => Interval a -> Property @@ -242,7 +229,7 @@ \[ \forall i,j i:j \implies \lnot j:i - \] + \] -} prop_IAaxiomML2 :: (Ord a)=> M2set a -> Property @@ -259,7 +246,7 @@ \[ \forall i \exists j,k s.t. j:i:k - \] + \] -} prop_IAaxiomM3 :: (IntervalSizeable a b)=> @@ -282,8 +269,8 @@ If two meets are separated by intervals, then this sequence is a longer interval. \[ - \forall i,j i:j \implies (\exists k,m,n s.t m:i:j:n \text { & } m:k:n) - \] + \forall i,j i:j \implies (\exists k,m,n s.t m:i:j:n \text { & } m:k:n) + \] -} prop_IAaxiomM4 :: (IntervalSizeable a b)=> @@ -314,7 +301,7 @@ \[ \forall i,j,k,l (i:j:l \text{ & } i:k:l) \equiv j = k - \] + \] -} prop_IAaxiomM5 :: (IntervalSizeable a b) => M5set a -> Property @@ -335,7 +322,7 @@ \[ \forall i,j i:j \implies (\exists m,n s.t. m:i:j:n \text{ & } m:(i+j):n) - \] + \] -} prop_IAaxiomM4_1 :: (IntervalSizeable a b)=> b -> M2set a -> Property diff --git a/src/IntervalAlgebra/Core.hs b/src/IntervalAlgebra/Core.hs --- a/src/IntervalAlgebra/Core.hs +++ b/src/IntervalAlgebra/Core.hs @@ -24,14 +24,14 @@ -} -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module IntervalAlgebra.Core ( @@ -120,84 +120,30 @@ , IntervalSizeable(..) ) where -import Control.Applicative ( Applicative(pure) - , liftA2 - ) -import Control.DeepSeq ( NFData ) -import Data.Binary ( Binary ) -import Data.Fixed ( Pico ) -import Data.Function ( ($) - , (.) - , flip - , id - ) -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 - , curry - , fromInteger - , fromRational - , map - , negate - , not - , otherwise - , realToFrac - , replicate - , show - , toInteger - , toRational - ) -import Test.QuickCheck ( Arbitrary(..) - , resize - , sized - , suchThat - ) +import Control.Applicative (Applicative (pure), liftA2) +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Fixed (Pico) +import Data.Function (flip, id, ($), (.)) +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, curry, + fromInteger, fromRational, map, negate, + not, otherwise, realToFrac, replicate, + show, toInteger, toRational, (!!), (&&), + (+), (++), (-), (==)) +import Test.QuickCheck (Arbitrary (..), resize, sized, suchThat) {- $setup >>> import IntervalAlgebra.IntervalDiagram diff --git a/src/IntervalAlgebra/IntervalDiagram.hs b/src/IntervalAlgebra/IntervalDiagram.hs --- a/src/IntervalAlgebra/IntervalDiagram.hs +++ b/src/IntervalAlgebra/IntervalDiagram.hs @@ -5,23 +5,23 @@ >>> let ref = bi 30 (0 :: Int) >>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ] ->>> pretty $ simpleIntervalDiagram ref ivs --- - ----- - ------ +>>> pretty $ simpleIntervalDiagram ref ivs +-- + ----- + ------ ============================== >>> 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 --- - ----- +>>> 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: +There are two main functions available: * @'parseIntervalDiagram'@: exposes all available options @@ -29,15 +29,15 @@ * @'simpleIntervalDiagram'@ produces simple diagram using defaults. -} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} module IntervalAlgebra.IntervalDiagram ( @@ -69,27 +69,15 @@ , Prettyprinter.Pretty(..) ) 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 - , pack - ) +import Data.Foldable (Foldable (toList)) +import qualified Data.List.NonEmpty as NE hiding (toList) +import Data.Maybe (fromMaybe, isNothing) +import Data.Text (Text, pack) import IntervalAlgebra.Core -import IntervalAlgebra.IntervalUtilities - ( rangeInterval ) -import IntervalAlgebra.PairedInterval ( PairedInterval - , getPairData - , makePairedInterval - ) +import IntervalAlgebra.IntervalUtilities (rangeInterval) +import IntervalAlgebra.PairedInterval (PairedInterval, getPairData, + makePairedInterval) import Prettyprinter -import Witch ( From(..) - , into - ) -- $setup -- >>> :set -XTypeApplications -XFlexibleContexts -XOverloadedStrings @@ -115,10 +103,6 @@ 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. - >>> pretty $ makeIntervalText '-' (beginerval 5 (0::Int)) ----- >>> pretty $ makeIntervalText '*' (beginerval 10 (0::Int)) @@ -140,15 +124,6 @@ c = getPairData x i = getInterval x -instance From (Char, Interval a) (IntervalText a) where - from = uncurry makeIntervalText - -instance From (IntervalText a) Char where - from (MkIntervalText x) = getPairData x - -instance From (IntervalText a) (Interval a) where - from = getInterval - {------------------------------------------------------------------------------- IntervalTextLine -------------------------------------------------------------------------------} @@ -159,22 +134,22 @@ Values of this type should only be created through the 'parseIntervalTextLine' function, -which checks that the inputs are parsed correctly to form intervals +which checks that the inputs are parsed correctly to form intervals that will be pretty-printed correctly. >>> let i1 = makeIntervalText '*' (beginerval 10 (5::Int)) >>> let i2 = makeIntervalText '-' (beginerval 2 (1::Int)) ->>> let x = parseIntervalTextLine [] [i1, i2] +>>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x UnsortedIntervals >>> let i1 = makeIntervalText '*' (beginerval 10 (5::Int)) >>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) ->>> let x = parseIntervalTextLine [] [i1, i2] +>>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x ConcurringIntervals >>> let i1 = makeIntervalText '*' (beginerval 10 ((-1)::Int)) >>> let i2 = makeIntervalText '-' (beginerval 2 (10::Int)) ->>> let x = parseIntervalTextLine [] [i1, i2] +>>> let x = parseIntervalTextLine [] [i1, i2] >>> pretty x BeginsLessThanZero >>> let i1 = makeIntervalText '*' (beginerval 5 (0::Int)) @@ -221,7 +196,7 @@ when a list of @IntervalText@ is parsed into a @IntervalTextLine@. -} data IntervalTextLineParseError = - -- | The inputs contains concurring intervals. + -- | The inputs contains concurring intervals. -- All inputs should be @'disjoint'@. ConcurringIntervals -- | The inputs are not sorted. @@ -257,7 +232,7 @@ {- Modifies the inputs sequentially so that the begin of one interval is - shifted based on the end of the previous interval. + shifted based on the end of the previous interval. This function assumes that the inputs are sorted and disjoint. -} makeIntervalLine @@ -274,7 +249,7 @@ {------------------------------------------------------------------------------- - Axis Config and Components + Axis Config and Components -------------------------------------------------------------------------------} {-| @@ -283,14 +258,17 @@ data AxisPlacement = -- | Print the axis at the top of the diagram Top - -- | Print the axis at the bottom of the diagram + -- | 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@. +Key-value list data that can be presented below the axis on an +@IntervalDiagram@. First element of the tuple is an Int key, the second the +Char to print. Note that it does not guarantee uniqueness of the keys, and most +if not all functions should first call @intMapList@ on the internal +@NE.NonEmpty@ list before using this type. -} -newtype AxisLabels = MkAxisLabels (NEM.NEIntMap Char) +newtype AxisLabels = MkAxisLabels (NE.NonEmpty (Int, Char)) deriving (Eq, Show) {-| @@ -303,10 +281,22 @@ } deriving (Eq, Show) +-- Internal utility to give equivalent structure to IntMap from +-- Data.IntMap.NonEmpty for the key-value list in @AxisLabels@. Previously, +-- when using IntMap for the @AxisLabels@ container, uniqueness and ordering of +-- keys was guaranteed. Now, you should first call this function before using +-- those keys, e.g. in @prettyAxisLabels@, to get the same properties. This has +-- a runtime cost and could be rewritten for efficiency if that were a concern. +-- NOTE: NE does not have a sortOn. +intMapList :: NE.NonEmpty (Int, a) -> NE.NonEmpty (Int, a) +intMapList = NE.sortBy (\(k, _) (k', _) -> compare k k') + . NE.nubBy (\(k, _) (k', _) -> k == k') + prettyAxisLabels :: AxisPlacement -> AxisLabels -> [Doc ann] prettyAxisLabels pos (MkAxisLabels labs) = do - let ints = NEM.keys labs - let marks = toList $ NEM.elems labs + let labssorted = intMapList labs + let ints = NE.map fst labssorted + let marks = toList $ NE.map snd labssorted let labPos = NE.head ints : zipWith (\x y -> y - x - 1) (toList ints) (NE.tail ints) let out = @@ -318,7 +308,7 @@ Bottom -> out {------------------------------------------------------------------------------- - Axis + Axis -------------------------------------------------------------------------------} {-| @@ -327,14 +317,14 @@ Use 'parseAxis' for construction. >>> let ref = makeIntervalText '=' (beginerval 10 (0::Int)) - + >>> let b = parseAxis [] (Just Top) ref ->>> pretty b +>>> pretty b ========== >>> let c = parseAxis [(4, 'a'), (6, 'b')] (Just Top) ref ->>> pretty c +>>> pretty c a b | | ========== @@ -396,8 +386,8 @@ -- 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 labels = intMapList <$> NE.nonEmpty l + let labPos = NE.map fst <$> labels let inputLabelCount = length l if | @@ -405,7 +395,7 @@ 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 +-- 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. @@ -457,9 +447,9 @@ :: IntervalDiagramOptions -> Either IntervalDiagramOptionsError IntervalDiagramOptions parseDiagramOptions opts = if - | leftPadding opts < 0 -> Left LeftPaddingLessThan0 + | leftPadding opts < 0 -> Left LeftPaddingLessThan0 | layoutPageWidth (layout opts) == Unbounded -> Left UnboundedPageWidth - | otherwise -> Right opts + | otherwise -> Right opts where isSorted xs = and $ zipWith (<=) xs (tail xs) -- | Default 'IntervalDiagramOptions' options @@ -503,10 +493,10 @@ -- | 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@ + -- | 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. @@ -529,13 +519,13 @@ -- Position line labels relative to the reference interval -- and the end of the last interval in a line. - -- NOTE: + -- 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. + -- not to the reference interval. -- See use of makeIntervalLine in parseIntervalTextLine. - -- This why the intervalLineEnd function is used to determine + -- This why the intervalLineEnd function is used to determine -- the end of the intervals in a line. let labelIndents = fmap (diff refDur . intervalLineEnd) ivs @@ -578,14 +568,14 @@ Here's a basic diagram that shows how to put more than one interval interval on a line: ->>> let mkIntrvl c d b = into @(IntervalText Int) (c, bi d (b :: Int)) +>>> let mkIntrvl c d b = makeIntervalText c (bi d (b :: Int)) >>> 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 + - + *** ***** x ## ==================== @@ -594,16 +584,16 @@ >>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [] (Just Top) x [ (l1, []), (l2, []), (l3, []) ] ==================== - - - *** ***** x + - + *** ***** x ## We can annotate the axis: >>> pretty $ parseIntervalDiagram defaultIntervalDiagramOptions [(5, 'a')] (Just Bottom) x [ (l1, []), (l2, []), (l3, []) ] - - - *** ***** x + - + *** ***** x ## ==================== | @@ -692,7 +682,7 @@ {-| Given a reference interval and a list of intervals, produces an 'IntervalDiagram' with one line per interval, -using the 'defaultIntervalDiagramOptions'. +using the 'defaultIntervalDiagramOptions'. >>> pretty $ simpleIntervalDiagram (bi 10 (0 :: Int)) (fmap (bi 1) [0..9]) - @@ -709,7 +699,7 @@ >>> let ref = bi 30 (0 :: Int) >>> let ivs = [ bi 2 0, bi 5 10, bi 6 16 ] ->>> pretty $ simpleIntervalDiagram ref ivs +>>> pretty $ simpleIntervalDiagram ref ivs -- ----- ------ diff --git a/src/IntervalAlgebra/IntervalUtilities.hs b/src/IntervalAlgebra/IntervalUtilities.hs --- a/src/IntervalAlgebra/IntervalUtilities.hs +++ b/src/IntervalAlgebra/IntervalUtilities.hs @@ -8,11 +8,11 @@ -} -{-# LANGUAGE Safe #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module IntervalAlgebra.IntervalUtilities ( @@ -78,109 +78,55 @@ , durations ) where -import safe Control.Applicative ( (<$>) - , (<*>) - , Applicative(pure) - , liftA2 - ) -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' - , foldr - , null - , toList - ) - , all - , any - , or - ) -import safe Data.Function ( ($) - , (.) - , flip - ) -import safe Data.List ( map - , reverse - , sortOn - ) -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 - , uncurry - ) -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 - , bi - , concur - , contains - , disjoint - , during - , enclosedBy - , encloses - , 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 - ) +import safe Control.Applicative (Applicative (pure), + liftA2, (<$>), (<*>)) +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', foldr, null, toList), + all, any, or) +import safe Data.Function (flip, ($), (.)) +import safe Data.List (map, reverse, sortOn) +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, uncurry) +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, bi, + concur, contains, + disjoint, during, + enclosedBy, encloses, 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) {- $setup >>> import GHC.List ( (++), zip ) @@ -237,7 +183,7 @@ go [] = [] go (x : xs) = fmap (x, ) xs <> go xs --- | Creates a new @Interval@ of a provided lookback duration ending at the +-- | Creates a new @Interval@ of a provided lookback duration ending at the -- 'begin' of the input interval. -- -- >>> lookback 4 (beginerval 10 (1 :: Int)) @@ -249,7 +195,7 @@ -> Interval a lookback d x = enderval d (begin x) --- | Creates a new @Interval@ of a provided lookahead duration beginning at the +-- | Creates a new @Interval@ of a provided lookahead duration beginning at the -- 'end' of the input interval. -- -- >>> lookahead 4 (beginerval 1 (1 :: Int)) @@ -299,8 +245,8 @@ allGapsWithinLessThanDuration = makeGapsWithinPredicate all (<) --- 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 +-- 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 @@ -311,7 +257,7 @@ listCombiner f x y = initSafe x <> f (lastMay x) (headMay y) <> tailSafe y {-# INLINABLE listCombiner #-} --- | Returns a list of the 'IntervalRelation' between each consecutive pair +-- | Returns a list of the 'IntervalRelation' between each consecutive pair -- of intervals. This is just a specialized 'relations' which returns a list. -- -- >>> relationsL [bi 1 0, bi 1 1] @@ -321,7 +267,7 @@ :: (Foldable f, Ord a, Intervallic i) => f (i a) -> [IntervalRelation] relationsL = relations --- | A generic form of 'relations' which can output any 'Applicative' and +-- | A generic form of 'relations' which can output any 'Applicative' and -- 'Monoid' structure. -- -- >>> (relations [bi 1 0,bi 1 1]) :: [IntervalRelation] @@ -340,9 +286,9 @@ relations = L.fold (makeFolder relate) {-# INLINABLE relations #-} --- | Forms a 'Just' new interval from the intersection of two intervals, +-- | Forms a 'Just' new interval from the intersection of two intervals, -- provided the intervals are not disjoint. --- +-- -- >>> intersect (bi 5 0) (bi 2 3) -- Just (3, 5) -- @@ -478,7 +424,7 @@ durations = fmap duration -- | In the case that x y are not disjoint, clips y to the extent of x. --- +-- -- >>> clip (bi 5 0) ((bi 3 3) :: Interval Int) -- Just (3, 5) -- @@ -502,10 +448,10 @@ {-# INLINABLE clip #-} -- | Applies 'gaps' to all the non-disjoint intervals in @x@ that are /not/ disjoint --- from @i@. Intervals that 'overlaps' or are 'overlappedBy' @i@ are 'clip'ped --- to @i@, so that all the intervals are 'within' @i@. If all of the input intervals --- are disjoint from the focal interval or if the input is empty, then 'Nothing' --- is returned. When there are no gaps among the concurring intervals, then +-- from @i@. Intervals that 'overlaps' or are 'overlappedBy' @i@ are 'clip'ped +-- to @i@, so that all the intervals are 'within' @i@. If all of the input intervals +-- are disjoint from the focal interval or if the input is empty, then 'Nothing' +-- is returned. When there are no gaps among the concurring intervals, then -- @Just mempty@ (e.g. @Just []@) is returned. -- -- >>> gapsWithin (bi 9 1) [bi 5 0, bi 2 7, bi 3 12] @@ -679,7 +625,7 @@ rangeInterval :: (Ord a, L.Foldable t) => t (Interval a) -> Maybe (Interval a) rangeInterval = L.fold (liftA2 extenterval <$> L.minimum <*> L.maximum) --- | Given a predicate combinator, a predicate, and list of intervals, returns +-- | 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 @@ -693,7 +639,7 @@ -- | Returns the 'Nothing' if *none* of the element of input satisfy -- the predicate condition. --- +-- -- For example, the following returns 'Nothing' because none of the intervals -- in the input list 'starts' (3, 5). -- @@ -739,8 +685,8 @@ -> 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@. +-- | 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, Intervallic i1) => ComparativePredicateOf2 (i0 a) (i1 a) @@ -748,8 +694,8 @@ -> (f (i1 a) -> f (i1 a)) makeFilter f p = Witherable.filter (f p) -{- | -Filter 'Witherable.Filterable' containers of one @'Intervallic'@ type based by comparing to +{- | +Filter 'Witherable.Filterable' containers of one @'Intervallic'@ type based by comparing to a (potentially different) 'Intervallic' type using the corresponding interval predicate function. -} @@ -778,21 +724,21 @@ filterEncloses = makeFilter encloses 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 +-- | 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. +-- 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 + => [PairedInterval b a] -- ^ Be sure this only contains intervals -- that sequentially 'meets'. -> [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. +-- | 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] @@ -800,7 +746,7 @@ foldMeeting (Meeting l) = foldl' joinMeetingPairedInterval (Meeting []) (packMeeting l) --- This type identifies that @a@ contains intervals that sequentially meet one +-- This type identifies that @a@ contains intervals that sequentially meet one -- another. newtype Meeting a = Meeting { getMeeting :: a } deriving (Eq, Show) @@ -845,12 +791,12 @@ 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 -two events have different states, creating a sequence (list) of new events that +two events have different states, creating a sequence (list) of new events that sequentially meet one another. Since x <= y, there are 7 possible interval -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. +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) @@ -881,13 +827,13 @@ evp b e = ev (beginerval (diff e b) b) {-# INLINABLE disjoinPaired #-} -{- | +{- | The internal function for converting a non-disjoint, ordered sequence of events into a disjoint, ordered sequence of events. The function operates -by recursion on a pair of events and the input events. The first of the -is the accumulator set -- the disjoint events that need no longer be +by recursion on a pair of events and the input events. The first of the +is the accumulator set -- the disjoint events that need no longer be compared to input events. The second of the pair are disjoint events that -still need to be compared to be input events. +still need to be compared to be input events. -} recurseDisjoin :: (Monoid b, Eq b, IntervalSizeable a c, Show a) @@ -895,19 +841,19 @@ -> [(PairedInterval b) a] -> [(PairedInterval b) a] recurseDisjoin (acc, o : os) [] = acc <> (o : os) -- the "final" pattern -recurseDisjoin (acc, [] ) [] = acc -- another "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 + | -- the "operating" patterns -- If input event is equal to the first comparator, skip the comparison. 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. - That is, since the inputs events are ordered, once the beginning of o - 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 + {- If o is either before or meets e, then + the first of the combined events can be put into the accumulator. + That is, since the inputs events are ordered, once the beginning of o + 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) @@ -922,12 +868,12 @@ nt = tailSafe n {-# INLINABLE recurseDisjoin #-} -{- | +{- | Convert an ordered sequence of @PairedInterval b a@. that may have any interval relation -('before', 'starts', etc) into a sequence of sequentially meeting @PairedInterval b a@. -That is, a sequence where one the end of one interval meets the beginning of +('before', 'starts', etc) into a sequence of sequentially meeting @PairedInterval b a@. +That is, a sequence where one the end of one interval meets the beginning of the subsequent event. The 'getPairData' of the input @PairedIntervals@ are -combined using the Monoid '<>' function, hence the pair data must be a +combined using the Monoid '<>' function, hence the pair data must be a 'Monoid' instance. -} formMeetingSequence @@ -940,7 +886,7 @@ | otherwise = formMeetingSequence (recurseDisjoin ([], []) x) -- recurseDisjoin ([], []) (recurseDisjoin ([], []) (recurseDisjoin ([], []) x)) - -- the multiple passes of recurseDisjoin is to handle the situation where the + -- the multiple passes of recurseDisjoin is to handle the situation where the -- initial passes almost disjoins all the events correctly into a meeting sequence -- but due to nesting of intervals in the input -- some of the sequential pairs have -- the same data after the first pass. The recursive passes merges any sequential diff --git a/src/IntervalAlgebra/PairedInterval.hs b/src/IntervalAlgebra/PairedInterval.hs --- a/src/IntervalAlgebra/PairedInterval.hs +++ b/src/IntervalAlgebra/PairedInterval.hs @@ -1,5 +1,5 @@ {-| -Module : Paired interval +Module : Paired interval Description : Extends the Interval Algebra to an interval paired with some data. Copyright : (c) NoviSci, Inc 2020 License : BSD3 @@ -7,10 +7,10 @@ Stability : experimental -} {-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} module IntervalAlgebra.PairedInterval ( PairedInterval @@ -23,20 +23,16 @@ , trivialize ) where -import safe Control.Applicative ( liftA2 ) -import safe Control.DeepSeq ( NFData ) -import safe Data.Binary ( Binary ) -import safe GHC.Generics ( Generic ) -import safe IntervalAlgebra.Core ( ComparativePredicateOf1 - , Interval - , IntervalCombinable(..) - , IntervalSizeable - , Intervallic(..) - , before - , extenterval - ) -import safe Test.QuickCheck ( Arbitrary(..) ) -import safe Witherable ( Filterable(filter) ) +import safe Control.Applicative (liftA2) +import safe Control.DeepSeq (NFData) +import safe Data.Binary (Binary) +import safe GHC.Generics (Generic) +import safe IntervalAlgebra.Core (ComparativePredicateOf1, Interval, + IntervalCombinable (..), + IntervalSizeable, Intervallic (..), + before, extenterval) +import safe Test.QuickCheck (Arbitrary (..)) +import safe Witherable (Filterable (filter)) -- | An @Interval a@ paired with some other data of type @b@. newtype PairedInterval b a = PairedInterval (Interval a, b) @@ -67,7 +63,7 @@ | otherwise = pure $ makePairedInterval (getPairData x <> getPairData y) (extenterval x y) --- | Make a paired interval. +-- | Make a paired interval. makePairedInterval :: b -> Interval a -> PairedInterval b a makePairedInterval d i = PairedInterval (i, d) @@ -90,7 +86,6 @@ x <> y = Empty instance Monoid Empty where 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. diff --git a/src/IntervalAlgebra/RelationProperties.hs b/src/IntervalAlgebra/RelationProperties.hs --- a/src/IntervalAlgebra/RelationProperties.hs +++ b/src/IntervalAlgebra/RelationProperties.hs @@ -5,7 +5,7 @@ License : BSD3 Maintainer : bsaul@novisci.com -This module exports a single typeclass @IntervalAxioms@ which contains +This module exports a single typeclass @IntervalAxioms@ which contains property-based tests for the axioms in section 1 of [Allen and Hayes (1987)](https://doi.org/10.1111/j.1467-8640.1989.tb00329.x). The notation below is that of the original paper. @@ -13,34 +13,21 @@ -} {- HLINT ignore -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module IntervalAlgebra.RelationProperties ( IntervalRelationProperties(..) ) where -import Data.Maybe ( fromJust - , isJust - , isNothing - ) -import Data.Set ( Set - , disjointUnion - , fromList - , member - ) -import Data.Time as DT - ( Day - , NominalDiffTime - , UTCTime - ) +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 - ) +import Test.QuickCheck (Arbitrary (arbitrary), Property, + (===), (==>)) allIArelations :: (Ord a) => [ComparativePredicateOf1 (Interval a)] allIArelations = @@ -59,7 +46,7 @@ , contains ] --- | A collection of properties for the interval algebra. Some of these come from +-- | 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 @@ -68,8 +55,8 @@ prop_exclusiveRelations x y = ( 1 == length (filter id $ map (\r -> r x y) allIArelations)) === True - -- | Given a set of interval relations and predicate function, test that the - -- predicate between two interval is equivalent to the relation of two intervals + -- | Given a set of interval relations and predicate function, test that the + -- 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 diff --git a/test-axioms/AxiomsSpec.hs b/test-axioms/AxiomsSpec.hs --- a/test-axioms/AxiomsSpec.hs +++ b/test-axioms/AxiomsSpec.hs @@ -1,28 +1,18 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} module AxiomsSpec ( spec ) where -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 - ) +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 diff --git a/test-relation-properties/RelationPropertiesSpec.hs b/test-relation-properties/RelationPropertiesSpec.hs --- a/test-relation-properties/RelationPropertiesSpec.hs +++ b/test-relation-properties/RelationPropertiesSpec.hs @@ -1,21 +1,15 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} module RelationPropertiesSpec ( spec ) where import Data.Time -import IntervalAlgebra.RelationProperties - ( IntervalRelationProperties(..) - ) -import Test.Hspec ( Spec - , describe - , hspec - , it - ) -import Test.Hspec.QuickCheck ( modifyMaxSuccess ) +import IntervalAlgebra.RelationProperties (IntervalRelationProperties (..)) +import Test.Hspec (Spec, describe, hspec, it) +import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck testScale = 100 diff --git a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs --- a/test/IntervalAlgebra/IntervalUtilitiesSpec.hs +++ b/test/IntervalAlgebra/IntervalUtilitiesSpec.hs @@ -6,104 +6,67 @@ ( 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 - , rangeInterval - , safeInterval - , starts - , strictWithinRelations - , withinRelations - ) -import IntervalAlgebra.Arbitrary ( arbitraryWithRelation ) -import IntervalAlgebra.IntervalUtilities - ( clip - , combineIntervals - , combineIntervalsFromSorted - , durations - , filterAfter - , filterBefore - , filterConcur - , filterContains - , filterDisjoint - , filterDuring - , filterEnclosedBy - , filterEncloses - , 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 ) +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, + rangeInterval, safeInterval, + starts, + strictWithinRelations, + withinRelations) +import IntervalAlgebra.Arbitrary (arbitraryWithRelation) +import IntervalAlgebra.IntervalUtilities (clip, combineIntervals, + combineIntervalsFromSorted, + durations, filterAfter, + filterBefore, filterConcur, + filterContains, + filterDisjoint, + filterDuring, + filterEnclosedBy, + filterEncloses, + 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 diff --git a/test/IntervalAlgebra/PairedIntervalSpec.hs b/test/IntervalAlgebra/PairedIntervalSpec.hs --- a/test/IntervalAlgebra/PairedIntervalSpec.hs +++ b/test/IntervalAlgebra/PairedIntervalSpec.hs @@ -3,26 +3,15 @@ ) where import Data.Bool -import Data.Time ( Day(ModifiedJulianDay) - , fromGregorian - ) -import IntervalAlgebra ( IntervalCombinable(..) - , IntervalSizeable(duration) - , before - , beginerval - , equals - , toEnumInterval - ) -import IntervalAlgebra.PairedInterval ( Empty(..) - , PairedInterval - , intervals - , makePairedInterval - ) -import Test.Hspec ( Spec - , describe - , it - , shouldBe - ) +import Data.Time (Day (ModifiedJulianDay), + fromGregorian) +import IntervalAlgebra (IntervalCombinable (..), + IntervalSizeable (duration), + before, beginerval, equals, + toEnumInterval) +import IntervalAlgebra.PairedInterval (Empty (..), PairedInterval, + intervals, makePairedInterval) +import Test.Hspec (Spec, describe, it, shouldBe) type TestPair = PairedInterval String Int @@ -72,6 +61,6 @@ 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 "monoid <>" $ Empty <> Empty `shouldBe` Empty it "ord empty" $ Empty < Empty `shouldBe` False it "ord empty" $ Empty <= Empty `shouldBe` True diff --git a/test/IntervalAlgebraSpec.hs b/test/IntervalAlgebraSpec.hs --- a/test/IntervalAlgebraSpec.hs +++ b/test/IntervalAlgebraSpec.hs @@ -1,54 +1,30 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} module IntervalAlgebraSpec ( spec ) where -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 - ) +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 diff --git a/tutorial/TutorialMain.hs b/tutorial/TutorialMain.hs --- a/tutorial/TutorialMain.hs +++ b/tutorial/TutorialMain.hs @@ -6,15 +6,22 @@ module Main where -- tag::import-declarations[] -import IntervalAlgebra -import IntervalAlgebra.IntervalDiagram +import IntervalAlgebra +import IntervalAlgebra.IntervalDiagram -import Data.Bifunctor ( Bifunctor(..) ) -import Data.List ( sort ) -import Data.Time - ( addDays, fromGregorian, secondsToDiffTime, Day, UTCTime(..) ) -import Witch ( into ) -import Data.Set ( fromList, difference, Set ) +import Data.Bifunctor ( Bifunctor(..) ) +import Data.List ( sort ) +import Data.Set ( Set + , difference + , fromList + ) +import Data.Time ( Day + , UTCTime(..) + , addDays + , fromGregorian + , secondsToDiffTime + ) +import Witch ( into ) -- end::import-declarations[] main :: IO () @@ -22,7 +29,8 @@ -- Add file header ----------------------------------------------------------- - putStrLn "Generated by running `cabal run tutorial -v0 > tutorial/TutorialMain.out`" + putStrLn + "Generated by running `cabal run tutorial -v0 > tutorial/TutorialMain.out`" putStrLn "Do not edit by hand\n\n" @@ -173,10 +181,13 @@ putStr "\nprint $ getInterval pairListstringInteger\n---> " print $ getInterval pairListstringInteger - putStr "\nprint $ setInterval pairListstringInteger (safeInterval (4, 9) :: Interval Integer)\n---> " - print $ setInterval pairListstringInteger (safeInterval (4, 9) :: Interval Integer) + putStr + "\nprint $ setInterval pairListstringInteger (safeInterval (4, 9) :: Interval Integer)\n---> " + print $ setInterval pairListstringInteger + (safeInterval (4, 9) :: Interval Integer) - putStr "\nprint $ intervals [pairListstringInteger, pairListstringInteger]\n---> " + putStr + "\nprint $ intervals [pairListstringInteger, pairListstringInteger]\n---> " print $ intervals [pairListstringInteger, pairListstringInteger] putStr "\nprint $ begin pairListstringInteger\n---> " @@ -198,7 +209,8 @@ putStr "\nprint $ getPairData pairStringDay\n---> " print $ getPairData pairStringDay - putStr "\nprint $ makePairedInterval \"ski trip\" (getInterval pairStringDay)\n---> " + putStr + "\nprint $ makePairedInterval \"ski trip\" (getInterval pairStringDay)\n---> " print $ makePairedInterval "ski trip" (getInterval pairStringDay) putStrLn "-- end::pairedinterval-getset-data-print[]" @@ -214,7 +226,8 @@ putStr "\nprint $ getInterval ivInteger\n---> " print $ getInterval ivInteger - putStr "\nprint $ setInterval ivInteger (beginerval 3 12 :: Interval Integer)\n---> " + putStr + "\nprint $ setInterval ivInteger (beginerval 3 12 :: Interval Integer)\n---> " print $ setInterval ivInteger (beginerval 3 12 :: Interval Integer) putStr "\nprint $ begin ivInteger\n---> " @@ -252,7 +265,8 @@ putStrLn "-- tag::intervalcombinable-interval-print[]" - putStrLn "\n-- The Just Interval formed from combining the Intervals, since iv0to2 `meets` iv2to5" + putStrLn + "\n-- The Just Interval formed from combining the Intervals, since iv0to2 `meets` iv2to5" putStr "print $ iv0to2 .+. iv2to5\n---> " print $ iv0to2 .+. iv2to5 @@ -260,7 +274,8 @@ putStr "print $ iv0to2 .+. iv5to8\n---> " print $ iv0to2 .+. iv5to8 - putStrLn "\n-- The Just Interval formed from the end of the first and the beginning of the\n-- second, since iv0to2 is `before` iv5to8" + putStrLn + "\n-- The Just Interval formed from the end of the first and the beginning of the\n-- second, since iv0to2 is `before` iv5to8" putStr "print $ iv0to2 >< iv5to8\n---> " print $ iv0to2 >< iv5to8 @@ -275,20 +290,26 @@ putStrLn "-- tag::intervalcombinable-pairedinterval-print[]" - putStrLn "\n-- The Just Interval formed from combining the Intervals and taking the data\n-- portion from the second argument, since iv0to2 `meets` iv2to5" - putStr "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv2to5\n---> " + putStrLn + "\n-- The Just Interval formed from combining the Intervals and taking the data\n-- portion from the second argument, since iv0to2 `meets` iv2to5" + putStr + "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv2to5\n---> " print $ makePairedInterval "a" iv0to2 .+. makePairedInterval "b" iv2to5 putStrLn "\n-- A Nothing since iv0to2 doesn't `meets` iv5to8" - putStr "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv5to8\n---> " + putStr + "print $ makePairedInterval \"a\" iv0to2 .+. makePairedInterval \"b\" iv5to8\n---> " print $ makePairedInterval "a" iv0to2 .+. makePairedInterval "b" iv5to8 - putStrLn "\n-- The Just Interval formed from spanning the Intervals and taking the data\n-- portion from the `mempty` method of the Monoid String instance, since\n-- iv0to2 is `before` iv5to8" - putStr "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv5to8\n---> " + putStrLn + "\n-- The Just Interval formed from spanning the Intervals and taking the data\n-- portion from the `mempty` method of the Monoid String instance, since\n-- iv0to2 is `before` iv5to8" + putStr + "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv5to8\n---> " print $ makePairedInterval "a" iv0to2 >< makePairedInterval "b" iv5to8 putStrLn "\n-- A Nothing since iv0to2 isn't `before` iv2to5" - putStr "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv2to5\n---> " + putStr + "print $ makePairedInterval \"a\" iv0to2 >< makePairedInterval \"b\" iv2to5\n---> " print $ makePairedInterval "a" iv0to2 >< makePairedInterval "b" iv2to5 putStrLn "-- end::intervalcombinable-pairedinterval-print[]" @@ -627,7 +648,8 @@ id1Event3 = makePairedInterval Enrollment (safeInterval (347, 422)) id1Event4 = makePairedInterval (Diagnosis RightAsRain) (safeInterval (12, 13)) id1Event5 = makePairedInterval (Treatment NewVaccine) (safeInterval (22, 23)) -id1Event6 = makePairedInterval (Diagnosis RightAsRain) (safeInterval (131, 132)) +id1Event6 = + makePairedInterval (Diagnosis RightAsRain) (safeInterval (131, 132)) id1Event7 = makePairedInterval (Diagnosis CommonCold) (safeInterval (161, 162)) id1Events :: SubjEvents @@ -653,8 +675,15 @@ id2Events :: SubjEvents id2Events = sort - [ id2Event1, id2Event2, id2Event3, id2Event4, id2Event5 , id2Event6 - , id2Event7, id2Event8 ] + [ id2Event1 + , id2Event2 + , id2Event3 + , id2Event4 + , id2Event5 + , id2Event6 + , id2Event7 + , id2Event8 + ] -- end::extended-example-1-study-data-subj-2[] @@ -663,7 +692,8 @@ id3Event1, id3Event2, id3Event3 :: StudyEvent id3Event1 = makePairedInterval Enrollment (safeInterval (7, 197)) -id3Event2 = makePairedInterval (Treatment StandardVaccine) (safeInterval (19, 20)) +id3Event2 = + makePairedInterval (Treatment StandardVaccine) (safeInterval (19, 20)) id3Event3 = makePairedInterval (Diagnosis Flu) (safeInterval (180, 181)) id3Events :: SubjEvents @@ -774,7 +804,7 @@ -> Maybe (i1 a) -> Maybe b calcDiff (Just y) (Just x) = Just $ diff (begin y) (end x) -calcDiff _ _ = Nothing +calcDiff _ _ = Nothing -- Calculate the difference between the end endpoint of the first Intervallic -- and the start endpoint of the second Intervallic @@ -784,7 +814,7 @@ -> Maybe (i1 a) -> Maybe b calcAtRisk (Just y) (Just x) = Just $ diff (end y) (end x) -calcAtRisk _ _ = Nothing +calcAtRisk _ _ = Nothing -- end::extended-example-1-processing-functions[] @@ -802,22 +832,8 @@ -------------------------------------------------------------------------------- diagr :: Either IntervalDiagramParseError (IntervalDiagram Integer) -diagr = parseIntervalDiagram - defaultIntervalDiagramOptions - [] - (Just Bottom) - (into @(IntervalText Integer) ('=', safeInterval (0, 12 :: Integer))) - [ ([deftIT iv0to2], ["iv0to2"]) - , ([deftIT iv2to4], ["iv2to4"]) - , ([deftIT iv2to5], ["iv2to5"]) - , ([deftIT iv3to6], ["iv3to6"]) - , ([deftIT iv4to5], ["iv4to5"]) - , ([deftIT iv6to8], ["iv6to8"]) - , ([deftIT iv5to8], ["iv5to8"]) - ] - -intoIntervalText :: Interval Integer -> IntervalText Integer -intoIntervalText x = into @(IntervalText Integer) ('-', x) - -deftIT :: Interval Integer -> IntervalText Integer -deftIT = intoIntervalText +diagr = standardExampleDiagram (zip ivs labels) [] + where + ivs = [iv0to2, iv2to4, iv2to5, iv3to6, iv4to5, iv6to8, iv5to8] + labels = + ["iv0to2", "iv2to4", "iv2to5", "iv3to6", "iv4to5", "iv6to8", "iv5to8"]