diff --git a/Bench/Range.hs b/Bench/Range.hs --- a/Bench/Range.hs +++ b/Bench/Range.hs @@ -4,7 +4,7 @@ import Control.Exception (evaluate) import Test.Tasty.Bench -import Data.Range +import Data.Ranges import qualified Data.Range.Algebra as Alg -- --------------------------------------------------------------------------- @@ -13,28 +13,53 @@ -- | N disjoint spans: [0,1], [3,4], [6,7], ... disjointSpans :: Int -> [Range Integer] -disjointSpans n = [fromIntegral (i * 3) +=+ fromIntegral (i * 3 + 1) | i <- [0 .. n - 1]] +disjointSpans n = + [ SpanRange (Bound (fromIntegral (i * 3)) Inclusive) (Bound (fromIntegral (i * 3 + 1)) Inclusive) + | i <- [0 .. n - 1] + ] -- | N fully overlapping spans all starting near 0 and ending far out overlappingSpans :: Int -> [Range Integer] -overlappingSpans n = [fromIntegral i +=+ fromIntegral (i + 1000) | i <- [0 .. n - 1]] +overlappingSpans n = + [ SpanRange (Bound (fromIntegral i) Inclusive) (Bound (fromIntegral (i + 1000)) Inclusive) + | i <- [0 .. n - 1] + ] --- | A pre-merged range list (already normalised) -mergedInput :: Int -> [Range Integer] +-- | N disjoint spans offset by 500000 (no overlap with disjointSpans) +offsetSpans :: Int -> [Range Integer] +offsetSpans n = + [ SpanRange (Bound (fromIntegral (i * 3) + 500000) Inclusive) (Bound (fromIntegral (i * 3 + 1) + 500000) Inclusive) + | i <- [0 .. n - 1] + ] + +-- | A pre-merged Ranges (already normalised) +mergedInput :: Int -> Ranges Integer mergedInput = mergeRanges . disjointSpans +-- | A pre-merged offset Ranges (for disjoint intersection benchmarks) +offsetMerged :: Int -> Ranges Integer +offsetMerged = mergeRanges . offsetSpans + +-- | Pre-merged overlapping Ranges +overlappingMerged :: Int -> Ranges Integer +overlappingMerged = mergeRanges . overlappingSpans + -- | Equivalent enumerated list for elem comparison elemList :: Int -> [Integer] elemList n = concatMap (\i -> [fromIntegral (i * 3) .. fromIntegral (i * 3 + 1)]) [0 .. n - 1] -- | Build a left-skewed union tree of N singleton ranges via the Algebra -unionTree :: Int -> Alg.RangeExpr [Range Integer] -unionTree n = foldl1 Alg.union [Alg.const [SingletonRange (fromIntegral i)] | i <- [1 .. n :: Int]] +unionTree :: Int -> Alg.RangeExpr (Ranges Integer) +unionTree n = foldl1 Alg.union + [ Alg.const (mergeRanges [SingletonRange (fromIntegral i)]) | i <- [1 .. n :: Int] ] -- | Build a left-skewed intersection tree of N overlapping span ranges via the Algebra -intersectionTree :: Int -> Alg.RangeExpr [Range Integer] +intersectionTree :: Int -> Alg.RangeExpr (Ranges Integer) intersectionTree n = foldl1 Alg.intersection - [Alg.const [fromIntegral (i * 2) +=+ fromIntegral (i * 2 + 100)] | i <- [1 .. n :: Int]] + [ Alg.const (mergeRanges [ SpanRange (Bound (fromIntegral (i * 2)) Inclusive) + (Bound (fromIntegral (i * 2 + 100)) Inclusive) ]) + | i <- [1 .. n :: Int] + ] -- --------------------------------------------------------------------------- -- Main @@ -46,55 +71,61 @@ ds10 <- evaluate . force $ disjointSpans 10 ds100 <- evaluate . force $ disjointSpans 100 ds1000 <- evaluate . force $ disjointSpans 1000 - ds10000 <- evaluate . force $ disjointSpans 10000 os10 <- evaluate . force $ overlappingSpans 10 os100 <- evaluate . force $ overlappingSpans 100 os1000 <- evaluate . force $ overlappingSpans 1000 ms10 <- evaluate . force $ mergedInput 10 ms100 <- evaluate . force $ mergedInput 100 ms1000 <- evaluate . force $ mergedInput 1000 + ms10000 <- evaluate . force $ mergedInput 10000 + off10 <- evaluate . force $ offsetMerged 10 + off100 <- evaluate . force $ offsetMerged 100 + off1000 <- evaluate . force $ offsetMerged 1000 + oms10 <- evaluate . force $ overlappingMerged 10 + oms100 <- evaluate . force $ overlappingMerged 100 + oms1000 <- evaluate . force $ overlappingMerged 1000 el1000 <- evaluate . force $ elemList 1000 el10000 <- evaluate . force $ elemList 10000 defaultMain [ bgroup "point-queries" [ bgroup "inRange" - [ bench "SpanRange" $ whnf (inRange (1 +=+ 1000000)) (500000 :: Integer) - , bench "LowerBoundRange" $ whnf (inRange (lbi 0)) (999999 :: Integer) - , bench "UpperBoundRange" $ whnf (inRange (ubi 1000000)) (1 :: Integer) - , bench "SingletonRange" $ whnf (inRange (SingletonRange 42)) (42 :: Integer) - , bench "InfiniteRange" $ whnf (inRange (InfiniteRange :: Range Integer)) 0 + [ bench "SpanRange" $ whnf (inRange (SpanRange (Bound 1 Inclusive) (Bound 1000000 Inclusive))) (500000 :: Integer) + , bench "LowerBoundRange" $ whnf (inRange (LowerBoundRange (Bound 0 Inclusive))) (999999 :: Integer) + , bench "UpperBoundRange" $ whnf (inRange (UpperBoundRange (Bound 1000000 Inclusive))) (1 :: Integer) + , bench "SingletonRange" $ whnf (inRange (SingletonRange 42)) (42 :: Integer) + , bench "InfiniteRange" $ whnf (inRange (InfiniteRange :: Range Integer)) 0 ] , bgroup "inRanges/disjoint-spans" - [ bench "10" $ whnf (inRanges ds10) 29 - , bench "100" $ whnf (inRanges ds100) 299 - , bench "1000" $ whnf (inRanges ds1000) 2999 - , bench "10000" $ whnf (inRanges ds10000) 29999 + [ bench "10" $ whnf (inRanges ms10) 29 + , bench "100" $ whnf (inRanges ms100) 299 + , bench "1000" $ whnf (inRanges ms1000) 2999 + , bench "10000" $ whnf (inRanges ms10000) 29999 ] , bgroup "inRanges/vs-elem" -- Checking for the last element — worst case for both - [ bench "inRanges-1000" $ whnf (inRanges ds1000) 2998 + [ bench "inRanges-1000" $ whnf (inRanges ms1000) 2998 , bench "elem-1000" $ whnf (elem (2998 :: Integer)) el1000 - , bench "inRanges-10000" $ whnf (inRanges ds10000) 29998 + , bench "inRanges-10000" $ whnf (inRanges ms10000) 29998 , bench "elem-10000" $ whnf (elem (29998 :: Integer)) el10000 ] , bgroup "aboveRanges/disjoint-spans" - [ bench "10" $ whnf (aboveRanges ds10) 10000 - , bench "100" $ whnf (aboveRanges ds100) 10000 - , bench "1000" $ whnf (aboveRanges ds1000) 10000 + [ bench "10" $ whnf (aboveRanges ms10) 10000 + , bench "100" $ whnf (aboveRanges ms100) 10000 + , bench "1000" $ whnf (aboveRanges ms1000) 10000 ] , bgroup "belowRanges/disjoint-spans" - [ bench "10" $ whnf (belowRanges ds10) (-1) - , bench "100" $ whnf (belowRanges ds100) (-1) - , bench "1000" $ whnf (belowRanges ds1000) (-1) + [ bench "10" $ whnf (belowRanges ms10) (-1) + , bench "100" $ whnf (belowRanges ms100) (-1) + , bench "1000" $ whnf (belowRanges ms1000) (-1) ] ] , bgroup "set-operations" [ bgroup "mergeRanges/already-merged" - [ bench "10" $ nf mergeRanges ms10 - , bench "100" $ nf mergeRanges ms100 - , bench "1000" $ nf mergeRanges ms1000 + [ bench "10" $ nf mergeRanges ds10 + , bench "100" $ nf mergeRanges ds100 + , bench "1000" $ nf mergeRanges ds1000 ] , bgroup "mergeRanges/fully-overlapping" [ bench "10" $ nf mergeRanges os10 @@ -112,15 +143,15 @@ , bench "1000" $ nf (union ms1000) ms1000 ] , bgroup "intersection/disjoint" - -- Two sets offset so they don't overlap — result is empty - [ bench "10" $ nf (intersection ms10) (fmap (fmap (+500000)) ms10) - , bench "100" $ nf (intersection ms100) (fmap (fmap (+500000)) ms100) - , bench "1000" $ nf (intersection ms1000) (fmap (fmap (+500000)) ms1000) + -- Two pre-merged sets offset so they share no values — result is empty + [ bench "10" $ nf (intersection ms10) off10 + , bench "100" $ nf (intersection ms100) off100 + , bench "1000" $ nf (intersection ms1000) off1000 ] , bgroup "intersection/overlapping" - [ bench "10" $ nf (intersection os10) os10 - , bench "100" $ nf (intersection os100) os100 - , bench "1000" $ nf (intersection os1000) os1000 + [ bench "10" $ nf (intersection oms10) oms10 + , bench "100" $ nf (intersection oms100) oms100 + , bench "1000" $ nf (intersection oms1000) oms1000 ] , bgroup "difference" [ bench "10" $ nf (difference ms10) ms10 @@ -136,14 +167,14 @@ , bgroup "construction-conversion" [ bgroup "fromRanges/take-N" - [ bench "take-100" $ nf (take 100 . fromRanges) ds10 - , bench "take-1000" $ nf (take 1000 . fromRanges) ds10 - , bench "take-10000" $ nf (take 10000 . fromRanges) ds10 + [ bench "take-100" $ nf (take 100 . fromRanges) ms10 + , bench "take-1000" $ nf (take 1000 . fromRanges) ms10 + , bench "take-10000" $ nf (take 10000 . fromRanges) ms10 ] , bgroup "joinRanges/adjacent" - [ bench "10" $ nf joinRanges ds10 - , bench "100" $ nf joinRanges ds100 - , bench "1000" $ nf joinRanges ds1000 + [ bench "10" $ nf joinRanges ms10 + , bench "100" $ nf joinRanges ms100 + , bench "1000" $ nf joinRanges ms1000 ] ] diff --git a/Data/Range.hs b/Data/Range.hs --- a/Data/Range.hs +++ b/Data/Range.hs @@ -1,492 +1,11 @@ {-# LANGUAGE Safe #-} --- | This module provides a simple api to access range functionality. It provides standard --- set operations on ranges, the ability to merge ranges together and, importantly, the ability --- to check if a value is within a range. The primary benifit of the Range library is performance --- and versatility. --- --- __Note:__ It is intended that you will read the documentation in this module from top to bottom. --- --- = Module guide --- --- * "Data.Range" — __start here__. Direct functions on @['Range' a]@. --- * "Data.Ranges" — 'Data.Ranges.Ranges' newtype with 'Monoid' \/ 'Semigroup' semantics (@('<>')@ means union). --- * "Data.Range.Ord" — 'Data.Range.Ord.KeyRange' and 'Data.Range.Ord.SortedRange' newtypes for 'Ord'-requiring contexts. --- * "Data.Range.Parser" — Parsec-based parser for CLI range strings. --- * "Data.Range.Algebra" — F-Algebra for deferred, efficient expression trees. --- --- = Understanding custom range syntax --- --- This library supports five different types of ranges: --- --- * 'SpanRange': A range starting from a value and ending with another value. --- * 'SingletonRange': This range is really just a shorthand for a range that starts and ends with the same value. --- * 'LowerBoundRange': A range that starts at a value and extends infinitely in the positive direction. --- * 'UpperBoundRange': A range that starts at a value and extends infinitely in the negative direction. --- * 'InfiniteRange': A range that includes all values in your range. --- --- All of these ranges are bounded in an 'Inclusive' or 'Exclusive' manner. --- --- To run through a simple example of what this looks like, let's start with mathematical notation and then --- move into our own notation. --- --- The bound @[1, 5)@ says "All of the numbers from one to five, including one but excluding 5." --- --- Using the data types directly, you could write this as: --- --- @SpanRange (Bound 1 Inclusive) (Bound 5 Exclusive)@ --- --- This is overly verbose, as a result, this library contains operators and functions for writing this much --- more succinctly. The above example could be written as: --- --- @1 +=* 5@ --- --- There the @+@ symbol is used to represent the inclusive side of a range and the @*@ symbol is used to represent --- the exclusive side of a range. --- --- The 'Show' instance of the 'Range' class will actually output these simplified helper functions, for example: --- --- >>> [SingletonRange 5, SpanRange (Bound 1 Inclusive) (Bound 5 Exclusive), InfiniteRange] --- [SingletonRange 5,1 +=* 5,inf] --- --- There are 'lbi', 'lbe', 'ubi' and 'ube' functions to create lower bound inclusive, lower bound exclusive, upper --- bound inclusive and upper bound exclusive ranges respectively. --- --- @SingletonRange x@ is equivalent to @x +=+ x@ but is nicer for presentational purposes in a 'Show'. --- --- Now that you know the basic syntax to declare ranges, the following uses cases will be easier to understand. --- --- = Use case 1: Basic Integer Range --- --- The standard use case for this library is efficiently discovering if an integer is within a given range. --- --- For example, if we had the range made up of the inclusive unions of @[5, 10]@ and @[20, 30]@ and @[25, Infinity)@ --- then we could instantiate, and simplify, such a range like this: --- --- >>> mergeRanges [(5 :: Integer) +=+ 10, 20 +=+ 30, lbi 25] --- [5 +=+ 10,lbi 20] --- --- You can then test if elements are within this range: --- --- >>> let ranges = mergeRanges [(5 :: Integer) +=+ 10, 20 +=+ 30, lbi 25] --- >>> inRanges ranges 7 --- True --- >>> inRanges ranges 50 --- True --- >>> inRanges ranges 15 --- False --- --- The other convenience methods in this library will help you perform more range operations. --- --- = Use case 2: Version ranges --- --- All the 'Data.Range' library really needs to work, is the Ord type. If you have a data type that can --- be ordered, than we can perform range calculations on it. The Data.Version type is an excellent example --- of this. For example, let's say that you want to say: "I accept a version range of [1.1.0, 1.2.1] or [1.3, 1.4) or [1.4, 1.4.2)" --- then you can write that as: --- --- @ --- \>\>\> :m + Data.Version --- \>\>\> let v x = Version x [] --- \>\>\> let ranges = mergeRanges [v [1, 1, 0] +=+ v [1,2,1], v [1,3] +=* v [1,4], v [1,4] +=* v [1,4,2]] --- \>\>\> inRanges ranges (v [1,0]) --- False --- \>\>\> inRanges ranges (v [1,5]) --- False --- \>\>\> inRanges ranges (v [1,1,5]) --- True --- \>\>\> inRanges ranges (v [1,3,5]) --- True --- @ --- --- As you can see, it is almost identical to the previous example, yet you are now comparing if a version is within a version range! --- Not only that, but so long as your type is orderable, the ranges can be merged together cleanly. --- --- With any luck, you can apply this library to your use case of choice. Good luck! -module Data.Range ( - -- * Range creation - (+=+), - (+=*), - (*=+), - (*=*), - lbi, - lbe, - ubi, - ube, - inf, - -- * Comparison functions - inRange, - inRanges, - aboveRange, - aboveRanges, - belowRange, - belowRanges, - rangesOverlap, - rangesAdjoin, - -- * Set operations - mergeRanges, - union, - intersection, - difference, - invert, - -- * Enumerable methods - fromRanges, - joinRanges, - -- * Data types - Bound(..), - BoundType(..), - Range(..) - ) where - --- $setup --- >>> import Data.Range - -import Data.Range.Data -import Data.Range.Operators -import Data.Range.Util -import Data.Range.RangeInternal (exportRangeMerge, joinRM, loadRanges, RangeMerge(..), buildSpanQuery) -import qualified Data.Range.Algebra as Alg - --- | Performs a set union between the two input ranges and returns the resultant set of --- ranges. The output is already in merged (canonical) form; a subsequent call to --- 'mergeRanges' is redundant. --- --- >>> union [1 +=+ 10] [5 +=+ (15 :: Integer)] --- [1 +=+ 15] --- --- See also 'intersection', 'difference', 'invert'. -union :: (Ord a) => [Range a] -> [Range a] -> [Range a] -union a b = Alg.eval $ Alg.union (Alg.const a) (Alg.const b) -{-# INLINE union #-} - --- | Performs a set intersection between the two input ranges and returns the resultant set of --- ranges. The output is already in merged (canonical) form; a subsequent call to --- 'mergeRanges' is redundant. --- --- >>> intersection [1 +=* 10] [5 +=+ (15 :: Integer)] --- [5 +=* 10] --- --- See also 'union', 'difference', 'invert'. -intersection :: (Ord a) => [Range a] -> [Range a] -> [Range a] -intersection a b = Alg.eval $ Alg.intersection (Alg.const a) (Alg.const b) -{-# INLINE intersection #-} - --- | Performs a set difference between the two input ranges and returns the resultant set of --- ranges. The output is already in merged (canonical) form; a subsequent call to --- 'mergeRanges' is redundant. --- --- >>> difference [1 +=+ 10] [5 +=+ (15 :: Integer)] --- [1 +=* 5] --- --- See also 'union', 'intersection', 'invert'. -difference :: (Ord a) => [Range a] -> [Range a] -> [Range a] -difference a b = Alg.eval $ Alg.difference (Alg.const a) (Alg.const b) -{-# INLINE difference #-} - --- | Returns the complement of the given ranges: all values /not/ covered by any --- of the input ranges. --- --- >>> invert [1 +=* 10, 15 *=+ (20 :: Integer)] --- [ube 1,10 +=+ 15,lbe 20] --- --- Note that @'invert' . 'invert' == 'id'@ for any list of ranges. --- --- See also 'union', 'intersection', 'difference'. -invert :: (Ord a) => [Range a] -> [Range a] -invert = Alg.eval . Alg.invert . Alg.const -{-# INLINE invert #-} - --- | A check to see if two ranges overlap. The ranges overlap if at least one value exists within both ranges. --- If they do overlap then true is returned; false otherwise. --- --- For example: --- --- >>> rangesOverlap (1 +=+ 5) (3 +=+ 7) --- True --- >>> rangesOverlap (1 +=+ 5) (5 +=+ 7) --- True --- >>> rangesOverlap (1 +=* 5) (5 +=+ 7) --- False --- --- The last case of these three is the primary "gotcha" of this method. With @[1, 5)@ and @[5, 7]@ there is no --- value that exists within both ranges. Therefore, technically, the ranges do not overlap. If you expected --- this to return True then it is likely that you would prefer to use 'rangesAdjoin' instead. -rangesOverlap :: (Ord a) => Range a -> Range a -> Bool -rangesOverlap a b = Overlap == (rangesOverlapType a b) - -rangesOverlapType :: (Ord a) => Range a -> Range a -> OverlapType -rangesOverlapType (SingletonRange a) x = rangesOverlapType (SpanRange b b) x - where - b = Bound a Inclusive -rangesOverlapType (SpanRange x y) (SpanRange a b) = boundsOverlapType (x, y) (a, b) -rangesOverlapType (SpanRange _ y) (LowerBoundRange lower) = againstLowerBound y lower -rangesOverlapType (SpanRange x _) (UpperBoundRange upper) = againstUpperBound x upper -rangesOverlapType (LowerBoundRange _) (LowerBoundRange _) = Overlap -rangesOverlapType (LowerBoundRange lower) (UpperBoundRange upper) = againstUpperBound lower upper -rangesOverlapType (UpperBoundRange _) (UpperBoundRange _) = Overlap -rangesOverlapType InfiniteRange _ = Overlap -rangesOverlapType a b = rangesOverlapType b a - --- | A check to see if two ranges adjoin. Ranges adjoin if they share no values but touch at a --- single boundary point — exactly one of the touching bounds is exclusive. --- --- For example: --- --- >>> rangesAdjoin (1 +=* 5) (5 +=+ 7) --- True --- >>> rangesAdjoin (1 +=+ 5) (5 *=+ 7) --- True --- >>> rangesAdjoin (1 +=+ 5) (3 +=+ 7) --- False --- --- The third case illustrates the distinction from 'rangesOverlap': @[1, 5]@ and @[3, 7]@ share --- values 3–5, so they overlap, not adjoin. See also 'rangesOverlap'. -rangesAdjoin :: (Ord a) => Range a -> Range a -> Bool -rangesAdjoin a b = Adjoin == (rangesOverlapType a b) - --- | Given a range and a value, returns 'True' if the value is within the range. --- Respects 'Inclusive' and 'Exclusive' bounds. --- --- See also 'inRanges' for testing against a list of ranges. --- --- The primary value of this library is performance and this method can be used to show --- this quite clearly. For example, you can try and approximate basic range functionality --- with "Data.List.elem" so we can generate an apples to apples comparison in GHCi: --- --- @ --- \>\>\> :set +s --- \>\>\> elem (10000000 :: Integer) [1..10000000] --- True --- (0.26 secs, 720,556,888 bytes) --- \>\>\> inRange (1 +=+ 10000000) (10000000 :: Integer) --- True --- (0.00 secs, 557,656 bytes) --- @ --- --- As you can see, this function is significantly more performant, in both speed and memory, --- than using the elem function. -inRange :: (Ord a) => Range a -> a -> Bool -inRange (SingletonRange a) value = value == a -inRange (SpanRange x y) value = Overlap == boundIsBetween (Bound value Inclusive) (x, y) -inRange (LowerBoundRange lower) value = Overlap == againstLowerBound (Bound value Inclusive) lower -inRange (UpperBoundRange upper) value = Overlap == againstUpperBound (Bound value Inclusive) upper -inRange InfiniteRange _ = True - --- | Returns 'True' if the value falls within any of the given ranges. --- This is the primary membership test for the library and is significantly more --- performant than approximating it with @'elem' x [lo..hi]@. --- --- The range list is canonicalised and a 'Data.Map'-backed lookup structure is --- built when this function is partially applied to its range argument. This --- means that when testing multiple values against the same set of ranges, --- partial application amortises the setup cost: --- --- @ --- -- Efficient: map is built once --- let memberOf = inRanges myRanges --- filter memberOf largeList --- --- -- Also fine for one-off checks --- inRanges myRanges someValue --- @ --- --- The first argument does not need to be in merged\/canonical form; the --- function canonicalises it internally. If the input is already canonical --- (e.g. the result of 'mergeRanges'), canonicalisation is a no-op. --- --- >>> inRanges [1 +=+ 10, 20 +=+ 30] (5 :: Integer) --- True --- >>> inRanges [1 +=+ 10, 20 +=+ 30] (15 :: Integer) --- False --- >>> inRanges [] (0 :: Integer) --- False --- --- See also 'inRange' for testing against a single range. -inRanges :: (Ord a) => [Range a] -> a -> Bool -inRanges rs = - case loadRanges rs of - IRM -> const True - RM lb ub spans -> buildSpanQuery lb ub spans - --- | Checks if the value provided is above (or greater than) the biggest value in --- the given range. --- --- The "LowerBoundRange" and the "InfiniteRange" will always --- cause this method to return False because you can't have a value --- higher than them since they are both infinite in the positive --- direction. --- --- >>> aboveRange (SingletonRange 5) (6 :: Integer) --- True --- >>> aboveRange (1 +=+ 5) (6 :: Integer) --- True --- >>> aboveRange (1 +=+ 5) (0 :: Integer) --- False --- >>> aboveRange (lbi 0) (6 :: Integer) --- False --- >>> aboveRange (ubi 0) (6 :: Integer) --- True --- >>> aboveRange inf (6 :: Integer) --- False -aboveRange :: (Ord a) => Range a -> a -> Bool -aboveRange (SingletonRange a) value = value > a -aboveRange (SpanRange _ y) value = Overlap == againstLowerBound (Bound value Inclusive) (invertBound y) -aboveRange (LowerBoundRange _) _ = False -aboveRange (UpperBoundRange upper) value = Overlap == againstLowerBound (Bound value Inclusive) (invertBound upper) -aboveRange InfiniteRange _ = False - --- | Returns 'True' if the value is strictly above (greater than the upper bound of) --- all of the given ranges. --- --- >>> aboveRanges [1 +=+ 5, 10 +=+ 15] (20 :: Integer) --- True --- >>> aboveRanges [1 +=+ 5, lbi 10] (20 :: Integer) --- False --- >>> aboveRanges [] (0 :: Integer) --- True --- --- See also 'aboveRange', 'belowRanges'. -aboveRanges :: (Ord a) => [Range a] -> a -> Bool -aboveRanges rs a = all (`aboveRange` a) rs - --- | Checks if the value provided is below (or less than) the smallest value in --- the given range. --- --- The "UpperBoundRange" and the "InfiniteRange" will always --- cause this method to return False because you can't have a value --- lower than them since they are both infinite in the negative --- direction. --- --- >>> belowRange (SingletonRange 5) (4 :: Integer) --- True --- >>> belowRange (1 +=+ 5) (0 :: Integer) --- True --- >>> belowRange (1 +=+ 5) (6 :: Integer) --- False --- >>> belowRange (lbi 6) (0 :: Integer) --- True --- >>> belowRange (ubi 6) (0 :: Integer) --- False --- >>> belowRange inf (6 :: Integer) --- False -belowRange :: (Ord a) => Range a -> a -> Bool -belowRange (SingletonRange a) value = value < a -belowRange (SpanRange x _) value = Overlap == againstUpperBound (Bound value Inclusive) (invertBound x) -belowRange (LowerBoundRange lower) value = Overlap == againstUpperBound (Bound value Inclusive) (invertBound lower) -belowRange (UpperBoundRange _) _ = False -belowRange InfiniteRange _ = False - --- | Returns 'True' if the value is strictly below (less than the lower bound of) --- all of the given ranges. --- --- >>> belowRanges [5 +=+ 10, 20 +=+ 30] (1 :: Integer) --- True --- >>> belowRanges [ubi 10, 20 +=+ 30] (1 :: Integer) --- False --- >>> belowRanges [] (0 :: Integer) --- True --- --- See also 'belowRange', 'aboveRanges'. -belowRanges :: (Ord a) => [Range a] -> a -> Bool -belowRanges rs a = all (`belowRange` a) rs - --- | An array of ranges may have overlaps; this function will collapse that array into as few --- Ranges as possible. For example: --- --- >>> mergeRanges [lbi 12, 1 +=+ 10, 5 +=+ (15 :: Integer)] --- [lbi 1] --- --- As you can see, the mergeRanges method collapsed multiple ranges into a single range that --- still covers the same surface area. --- --- This may be useful for a few use cases: --- --- * You are hyper concerned about performance and want to have the minimum number of ranges --- for comparison in the inRanges function. --- * You wish to display ranges to a human and want to show the minimum number of ranges to --- avoid having to make people perform those calculations themselves. --- --- Please note that the use of any of the operations on sets of ranges like invert, union and --- intersection will have the same behaviour as mergeRanges as a side effect. So, for example, --- this is redundant: --- --- @ --- mergeRanges . union [] --- @ --- --- See also 'joinRanges' for merging ranges that are contiguous for 'Enum' types. -mergeRanges :: (Ord a) => [Range a] -> [Range a] -mergeRanges = Alg.eval . Alg.union (Alg.const []) . Alg.const -{-# INLINE mergeRanges #-} - --- | Instantiate all of the values in a range. --- --- __Warning__: This method is meant as a convenience method, it is not efficient. --- --- A set of ranges represents a collection of real values without actually instantiating --- those values. Not instantiating ranges, allows the range library to support infinite --- ranges and be super performant. --- --- However, sometimes you actually want to get the values that your range represents, or even --- get a sample set of the values. This function generates as many of the values that belong --- to your range as you like. --- --- Because ranges can be infinite, it is highly recommended to combine this method with something like --- "Data.List.take" to avoid an infinite recursion. --- --- This method will attempt to take a sample from all of the ranges that you have provided, however --- it is not guaranteed that you will get an even sampling. All that is guaranteed is that you will --- only get back values that are within one or more of the ranges you provide. --- --- == Examples --- --- A simple span: --- --- >>> take 5 . fromRanges $ [1 +=+ 10 :: Range Integer, 20 +=+ 30] --- [1,20,2,21,3] --- --- An infinite range: +-- | __Deprecated.__ Import "Data.Ranges" instead. -- --- >>> take 5 . fromRanges $ [inf :: Range Integer] --- [0,1,-1,2,-2] -fromRanges :: (Ord a, Enum a) => [Range a] -> [a] -fromRanges = takeEvenly . fmap fromRange . mergeRanges - where - fromRange range = case range of - SingletonRange x -> [x] - SpanRange (Bound a aType) (Bound b bType) -> [(if aType == Inclusive then a else succ a)..(if bType == Inclusive then b else pred b)] - LowerBoundRange (Bound x xType) -> iterate succ (if xType == Inclusive then x else succ x) - UpperBoundRange (Bound x xType) -> iterate pred (if xType == Inclusive then x else pred x) - InfiniteRange -> zero : takeEvenly [tail $ iterate succ zero, tail $ iterate pred zero] - where - zero = toEnum 0 +-- This module is a re-export shim kept for backwards compatibility. +-- All types and functions are now in "Data.Ranges". +module Data.Range {-# DEPRECATED "Import Data.Ranges instead of Data.Range." #-} + ( module Data.Ranges + ) where --- | Joins together ranges that we only know can be joined because of the 'Enum' class. --- --- To make the purpose of this method easier to understand, let's run throuh a simple example: --- --- >>> mergeRanges [1 +=+ 5, 6 +=+ 10] :: [Range Integer] --- [1 +=+ 5,6 +=+ 10] --- --- In this example, you know that the values are all of the type 'Integer'. Because of this, you --- know that there are no values between 5 and 6. You may expect that the `mergeRanges` function --- should "just know" that it can merge these together; but it can't because it does not have the --- required constraints. This becomes more obvious if you modify the example to use 'Double' instead: --- --- >>> mergeRanges [1.5 +=+ 5.5, 6.5 +=+ 10.5] :: [Range Double] --- [1.5 +=+ 5.5,6.5 +=+ 10.5] --- --- Now we can see that there are an infinite number of values between 5.5 and 6.5 and thus no such --- join between the two ranges could occur. --- --- This function, joinRanges, provides the missing piece that you would expect: --- --- >>> joinRanges $ mergeRanges [1 +=+ 5, 6 +=+ 10] :: [Range Integer] --- [1 +=+ 10] --- --- You can use this method to ensure that all ranges for whom the value implements 'Enum' can be --- compressed to their smallest representation. --- --- See also 'mergeRanges' for the overlap-only merge that works on any 'Ord' type. -joinRanges :: (Ord a, Enum a) => [Range a] -> [Range a] -joinRanges = exportRangeMerge . joinRM . loadRanges +import Data.Ranges diff --git a/Data/Range/Algebra.hs b/Data/Range/Algebra.hs --- a/Data/Range/Algebra.hs +++ b/Data/Range/Algebra.hs @@ -9,8 +9,9 @@ -- -- __When to use this module:__ Build a 'RangeExpr' when you are combining three -- or more operations in a pipeline, or when you want to evaluate the same --- expression against multiple targets (e.g. both @['Range' a]@ and @a -> 'Bool'@). --- A single @union a b@ is no faster through the algebra than a direct call. +-- expression against multiple targets (e.g. both 'Data.Ranges.Ranges' and +-- @a -> 'Bool'@). A single @union a b@ is no faster through the algebra than +-- a direct call. -- -- __Note:__ This module is based on F-Algebras. If you have never encountered -- them before, see @@ -19,21 +20,28 @@ -- -- == Examples -- --- Evaluate to a concrete list of ranges: +-- Evaluate to a 'Data.Ranges.Ranges' value (the typical use): -- -- @ -- import qualified Data.Range.Algebra as A --- import Data.Range --- A.eval . A.invert $ A.const [SingletonRange (5 :: Integer)] --- -- [ube 4,lbi 6] +-- import Data.Ranges +-- +-- expr :: A.RangeExpr (Ranges Integer) +-- expr = A.invert (A.const (SingletonRange 5)) +-- +-- A.eval expr :: Ranges Integer +-- -- Ranges [ube 4,lbi 6] -- @ -- --- Evaluate the same expression as a predicate (no intermediate list is built): +-- Evaluate the same expression as a predicate (no intermediate structure built): -- -- @ --- let expr = A.union (A.const [1 +=+ 10]) (A.const [20 +=+ 30]) :: A.RangeExpr [Range Integer] --- (A.eval expr :: Integer -> Bool) 25 -- True --- (A.eval expr :: Integer -> Bool) 15 -- False +-- import qualified Data.Range.Algebra as A +-- import Data.Ranges +-- +-- let expr = A.union (A.const (1 +=+ 10)) (A.const (20 +=+ 30)) :: A.RangeExpr (Ranges Integer) +-- A.eval (fmap inRanges expr) 25 -- True +-- A.eval (fmap inRanges expr) 15 -- False -- @ -- module Data.Range.Algebra @@ -83,23 +91,29 @@ difference a b = RangeExpr . Free $ Difference (getFree a) (getFree b) -- | A type class for types that a 'RangeExpr' can be evaluated to. --- Two instances are provided out of the box; additional targets can be added +-- Three instances are provided out of the box; additional targets can be added -- by implementing this class. class RangeAlgebra a where -- | Collapses a 'RangeExpr' tree into its target representation by - -- evaluating every node bottom-up. Two evaluation targets are supported: + -- evaluating every node bottom-up. Three evaluation targets are supported: -- - -- * @['Data.Range.Range' a]@ — a merged, canonical list of non-overlapping ranges. - -- * @a -> 'Bool'@ — a membership predicate; no intermediate list is constructed. + -- * 'Data.Ranges.Ranges' @a@ — canonical, indexed set with pre-built + -- membership predicate. The primary target for user code; instance defined + -- in "Data.Ranges". + -- * @['Data.Range.Data.Range' a]@ — a merged, canonical list. Used internally + -- and useful when you need to inspect individual ranges. + -- * @a -> 'Bool'@ — a membership predicate; no intermediate structure built. eval :: Algebra RangeExpr a -- | Evaluates to a merged, canonical list of non-overlapping ranges. --- Input ranges are allowed to overlap; the output is guaranteed to be disjoint. +-- Used internally by "Data.Ranges" and useful when you need to inspect +-- individual 'Range' values. Prefer the 'Data.Ranges.Ranges' instance for +-- general use. instance (Ord a) => RangeAlgebra [Range a] where eval = iter rangeAlgebra . getFree -- | Evaluates to a membership predicate @a -> 'Bool'@. --- More efficient than the @['Range' a]@ instance when you only need to test --- membership and do not need to inspect the ranges themselves. +-- No intermediate structure is constructed. With 'Data.Ranges.Ranges' leaves, +-- use @'eval' ('fmap' 'Data.Ranges.inRanges' expr)@ to reach this instance. instance RangeAlgebra (a -> Bool) where eval = iter predicateAlgebra . getFree diff --git a/Data/Range/Data.hs b/Data/Range/Data.hs --- a/Data/Range/Data.hs +++ b/Data/Range/Data.hs @@ -48,13 +48,6 @@ instance NFData a => NFData (Range a) -instance Functor Range where - fmap f (SingletonRange x) = SingletonRange . f $ x - fmap f (SpanRange x y) = SpanRange (fmap f x) (fmap f y) - fmap f (LowerBoundRange x) = LowerBoundRange (fmap f x) - fmap f (UpperBoundRange x) = UpperBoundRange (fmap f x) - fmap _ InfiniteRange = InfiniteRange - instance Show a => Show (Range a) where showsPrec i (SingletonRange a) = ((++) "SingletonRange ") . showsPrec i a showsPrec i (SpanRange (Bound l lType) (Bound r rType)) = diff --git a/Data/Range/Parser.hs b/Data/Range/Parser.hs --- a/Data/Range/Parser.hs +++ b/Data/Range/Parser.hs @@ -4,19 +4,19 @@ -- -- By default, ranges are separated by commas and span endpoints by a hyphen: -- --- >>> parseRanges "-5,8-10,13-15,20-" :: Either ParseError [Range Integer] --- Right [ubi 5,8 +=+ 10,13 +=+ 15,lbi 20] +-- >>> parseRanges "-5,8-10,13-15,20-" :: Either ParseError (Ranges Integer) +-- Right (Ranges [ubi 5,8 +=+ 10,13 +=+ 15,lbi 20]) -- -- The @*@ wildcard produces an infinite range: -- --- >>> parseRanges "*" :: Either ParseError [Range Integer] --- Right [inf] +-- >>> parseRanges "*" :: Either ParseError (Ranges Integer) +-- Right (Ranges [inf]) -- -- Use 'customParseRanges' to change the separator characters: -- -- >>> let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." } --- >>> customParseRanges args "1..5;10" :: Either ParseError [Range Integer] --- Right [1 +=+ 5,SingletonRange 10] +-- >>> customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer) +-- Right (Ranges [1 +=+ 5,SingletonRange 10]) -- -- __Known limitations:__ -- @@ -25,13 +25,14 @@ -- For negative values, use 'customParseRanges' with a different 'rangeSeparator', -- or pre-process the input string. -- --- * Unrecognised input is silently consumed as an empty list rather than producing --- a parse error. For example, @parseRanges \"abc\"@ returns @Right []@. This is a +-- * Unrecognised input is silently consumed as an empty set rather than producing +-- a parse error. For example, @parseRanges \"abc\"@ returns @Right mempty@. This is a -- consequence of using 'Text.Parsec.sepBy' internally and is by design for -- CLI use where partial input is common. -- -- For more complex parsing (e.g. @.cabal@ or @package.json@ files), parse version --- strings with Parsec or Alex\/Happy and convert the results into 'Range' values directly. +-- strings with Parsec or Alex\/Happy and convert the results into 'Range' values directly, +-- then call 'mergeRanges'. module Data.Range.Parser ( -- * Parsing parseRanges @@ -48,13 +49,13 @@ ) where -- $setup --- >>> import Data.Range +-- >>> import Data.Ranges -- >>> import Data.Range.Parser import Text.Parsec import Text.Parsec.String -import Data.Range +import Data.Ranges -- | Configuration for the range parser. All three fields are plain strings, so -- multi-character separators (e.g. @\"..\"@) are supported. @@ -78,7 +79,8 @@ } -- | Parses a range string using the default separators (@,@ and @-@). Returns --- either a 'ParseError' or the list of parsed ranges. +-- either a 'ParseError' or a canonicalised 'Ranges' value ready for membership +-- testing and set operations. -- -- The 'Read' instance of @a@ is used to parse individual numeric literals, so -- the type must have a well-behaved 'Read'. Exotic types with unusual 'Read' @@ -86,17 +88,17 @@ -- -- See the module documentation for known limitations around negative numbers -- and unrecognised input. -parseRanges :: (Read a) => String -> Either ParseError [Range a] -parseRanges = parse (ranges defaultArgs) "(range parser)" +parseRanges :: (Read a, Ord a) => String -> Either ParseError (Ranges a) +parseRanges = fmap mergeRanges . parse (ranges defaultArgs) "(range parser)" -- | Like 'parseRanges' but with caller-supplied separator configuration. -- Use this when the default @,@ and @-@ characters conflict with your input format. -- -- >>> let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." } --- >>> customParseRanges args "1..5;10" :: Either ParseError [Range Integer] --- Right [1 +=+ 5,SingletonRange 10] -customParseRanges :: Read a => RangeParserArgs -> String -> Either ParseError [Range a] -customParseRanges args = parse (ranges args) "(range parser)" +-- >>> customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer) +-- Right (Ranges [1 +=+ 5,SingletonRange 10]) +customParseRanges :: (Read a, Ord a) => RangeParserArgs -> String -> Either ParseError (Ranges a) +customParseRanges args = fmap mergeRanges . parse (ranges args) "(range parser)" string_ :: Stream s m Char => String -> ParsecT s u m () string_ x = string x >> return () @@ -104,6 +106,9 @@ -- | Returns a Parsec 'Parser' for a list of ranges using the given configuration. -- Use this when embedding range parsing into a larger Parsec grammar; for -- standalone parsing prefer 'parseRanges' or 'customParseRanges'. +-- +-- The returned list is unmerged — call 'mergeRanges' on the result to produce +-- a canonical 'Ranges' value. ranges :: (Read a) => RangeParserArgs -> Parser [Range a] ranges args = range `sepBy` (string $ unionSeparator args) where diff --git a/Data/Range/RangeInternal.hs b/Data/Range/RangeInternal.hs --- a/Data/Range/RangeInternal.hs +++ b/Data/Range/RangeInternal.hs @@ -34,12 +34,18 @@ storeRange :: (Ord a) => Range a -> RangeMerge a storeRange InfiniteRange = IRM -storeRange (LowerBoundRange lower) = emptyRangeMerge { largestLowerBound = Just lower } -storeRange (UpperBoundRange upper) = emptyRangeMerge { largestUpperBound = Just upper } +storeRange (LowerBoundRange lower) = + RM { largestLowerBound = Just lower, largestUpperBound = Nothing, spanRanges = [] } +storeRange (UpperBoundRange upper) = + RM { largestLowerBound = Nothing, largestUpperBound = Just upper, spanRanges = [] } storeRange (SpanRange x@(Bound xValue xType) y@(Bound yValue yType)) | xValue == yValue && pointJoinType xType yType == Separate = emptyRangeMerge - | otherwise = emptyRangeMerge { spanRanges = [(minBounds x y, maxBounds x y)] } -storeRange (SingletonRange x) = emptyRangeMerge { spanRanges = [(Bound x Inclusive, Bound x Inclusive)] } + | otherwise = + RM { largestLowerBound = Nothing, largestUpperBound = Nothing + , spanRanges = [(minBounds x y, maxBounds x y)] } +storeRange (SingletonRange x) = + RM { largestLowerBound = Nothing, largestUpperBound = Nothing + , spanRanges = [(Bound x Inclusive, Bound x Inclusive)] } storeRanges :: (Ord a) => RangeMerge a -> [Range a] -> RangeMerge a storeRanges start ranges = foldr unionRangeMerges start (map storeRange ranges) @@ -62,7 +68,6 @@ then SingletonRange xv else SpanRange x y -{-# RULES "load/export" [1] forall x. loadRanges (exportRangeMerge x) = x #-} intersectSpansRM :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a intersectSpansRM one two = RM Nothing Nothing newSpans @@ -141,7 +146,9 @@ unionRangeMerges one two = infiniteCheck filterTwo where filterOne = foldr filterLowerBound boundedRM (unionSpans sortedSpans) - filterTwo = foldr filterUpperBound (filterOne { spanRanges = [] }) (spanRanges filterOne) + filterTwo = case filterOne of + IRM -> IRM + rm -> foldr filterUpperBound (rm { spanRanges = [] }) (spanRanges rm) infiniteCheck :: (Ord a) => RangeMerge a -> RangeMerge a infiniteCheck IRM = IRM @@ -195,31 +202,31 @@ invertRM (RM (Just lower) Nothing []) = RM Nothing (Just . invertBound $ lower) [] invertRM (RM Nothing (Just upper) []) = RM (Just . invertBound $ upper) Nothing [] invertRM (RM (Just lower) (Just upper) []) = RM Nothing Nothing [(invertBound upper, invertBound lower)] -invertRM rm = RM +invertRM (RM lb ub spans@(firstSpan : _)) = RM { largestUpperBound = newUpperBound , largestLowerBound = newLowerBound , spanRanges = upperSpan ++ betweenSpans ++ lowerSpan } where - newLowerValue = invertBound . snd . last . spanRanges $ rm - newUpperValue = invertBound . fst . head . spanRanges $ rm + newUpperValue = invertBound . fst $ firstSpan + newLowerValue = invertBound . snd . last $ spans - newUpperBound = case largestUpperBound rm of + newUpperBound = case ub of Just _ -> Nothing Nothing -> Just newUpperValue - newLowerBound = case largestLowerBound rm of + newLowerBound = case lb of Just _ -> Nothing Nothing -> Just newLowerValue - upperSpan = case largestUpperBound rm of + upperSpan = case ub of Nothing -> [] Just upper -> [(invertBound upper, newUpperValue)] - lowerSpan = case largestLowerBound rm of + lowerSpan = case lb of Nothing -> [] Just lower -> [(newLowerValue, invertBound lower)] - betweenSpans = invertSpans . spanRanges $ rm + betweenSpans = invertSpans spans joinRM :: (Eq a, Enum a) => RangeMerge a -> RangeMerge a joinRM o@(RM _ _ []) = o diff --git a/Data/Range/Util.hs b/Data/Range/Util.hs --- a/Data/Range/Util.hs +++ b/Data/Range/Util.hs @@ -1,15 +1,41 @@ {-# LANGUAGE Safe #-} -module Data.Range.Util where +-- | Internal utility functions shared across the range library. +-- This module is in @other-modules@ and is not part of the public API. +-- +-- Functions are grouped by the layer that consumes them: +-- * "Used by Ranges\/Ord" — consumed by the semi-public modules +-- * "Used by Spans\/RangeInternal" — consumed only by the strictly-internal layer +-- * "Util-internal" — building blocks used only within this module +module Data.Range.Util + ( -- * Used by Ranges and Ord + compareLower + , compareHigher + , invertBound + , boundsOverlapType + , pointJoinType + , boundIsBetween + , againstLowerBound + , againstUpperBound + , takeEvenly + -- * Used by Spans and RangeInternal + , compareUpperToLower + , minBounds + , maxBounds + , minBoundsIntersection + , maxBoundsIntersection + , insertionSort + , isEmptySpan + , removeEmptySpans + , boundCmp + , lowestValueInLowerBound + , highestValueInUpperBound + ) where import Data.List (transpose) import Data.Range.Data --- This module is supposed to contain all of the functions that are required by the rest --- of the code but could be easily pulled into separate and completely non-related --- codebases or libraries. - compareLower :: Ord a => Bound a -> Bound a -> Ordering compareLower ab@(Bound a aType) bb@(Bound b _) | ab == bb = EQ @@ -24,6 +50,7 @@ | a < b = LT | otherwise = GT +-- | Util-internal: used only by 'minBoundsIntersection'. compareLowerIntersection :: Ord a => Bound a -> Bound a -> Ordering compareLowerIntersection ab@(Bound a aType) bb@(Bound b _) | ab == bb = EQ @@ -31,6 +58,7 @@ | a < b = LT | otherwise = GT +-- | Util-internal: used only by 'maxBoundsIntersection'. compareHigherIntersection :: Ord a => Bound a -> Bound a -> Ordering compareHigherIntersection ab@(Bound a aType) bb@(Bound b _) | ab == bb = EQ @@ -83,6 +111,7 @@ | b == y = Overlap | otherwise = (ab `boundIsBetween` (xb, yb)) `orOverlapType` (xb `boundIsBetween` (ab, bb)) +-- | Util-internal: used only by 'boundsOverlapType'. orOverlapType :: OverlapType -> OverlapType -> OverlapType orOverlapType Overlap _ = Overlap orOverlapType _ Overlap = Overlap @@ -95,15 +124,22 @@ pointJoinType Exclusive Exclusive = Separate pointJoinType _ _ = Adjoin --- This function assumes that the bound on the left is a lower bound and that the range is in (lower, upper) --- bound order +-- | This function assumes that the bound on the left is a lower bound and +-- that the range is in @(lower, upper)@ bound order. boundCmp :: (Ord a) => Bound a -> (Bound a, Bound a) -> Ordering boundCmp ab@(Bound a _) (xb@(Bound x _), yb) | boundIsBetween ab (xb, yb) /= Separate = EQ | a <= x = LT | otherwise = GT --- TODO replace everywhere with boundsOverlapType +-- | Tests whether a single 'Bound' falls within the span @(lower, upper)@, +-- returning the 'OverlapType' at that point. +-- +-- This is the point-in-span primitive. 'boundsOverlapType' is built on top +-- of it and handles the span-vs-span case. Replacing call sites of this +-- function with 'boundsOverlapType' would require constructing a degenerate +-- span @(b, b)@ for each point — see @ai-planning/boundIsBetween-todo.md@ +-- for the full analysis. boundIsBetween :: (Ord a) => Bound a -> (Bound a, Bound a) -> OverlapType boundIsBetween (Bound a aType) (Bound x xType, Bound y yType) | x > a = Separate @@ -112,9 +148,6 @@ | a == y = pointJoinType aType yType | otherwise = Separate -singletonInSpan :: Ord a => a -> (Bound a, Bound a) -> OverlapType -singletonInSpan a span' = boundIsBetween (Bound a Inclusive) span' - againstLowerBound :: Ord a => Bound a -> Bound a -> OverlapType againstLowerBound (Bound a aType) (Bound lower lowerType) | lower == a = pointJoinType aType lowerType @@ -129,10 +162,6 @@ takeEvenly :: [[a]] -> [a] takeEvenly = concat . transpose - -pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs xs = zip xs (tail xs) lowestValueInLowerBound :: Enum a => Bound a -> a lowestValueInLowerBound (Bound a Inclusive) = a diff --git a/Data/Ranges.hs b/Data/Ranges.hs --- a/Data/Ranges.hs +++ b/Data/Ranges.hs @@ -1,28 +1,63 @@ {-# LANGUAGE Safe #-} --- | This module provides a 'Newtype' wrapper around @['Data.Range.Range' a]@ that --- integrates with standard Haskell type classes, making it easy to accumulate and --- compose ranges using familiar idioms. +-- | The primary interface to the range library. -- --- The primary advantage over "Data.Range" is that 'Ranges' implements 'Semigroup' --- and 'Monoid', where @('<>')@ means /union-and-merge/. This composes naturally with --- standard Haskell functions: +-- A 'Range' describes a membership set over any 'Ord' type. This module +-- provides the 'Ranges' type — a canonicalised, indexed collection of +-- 'Range' values — along with construction operators, set operations, and +-- membership predicates. -- --- >>> import Data.Foldable (fold) --- >>> fold [1 +=+ 5, 3 +=+ 8, lbi 20 :: Ranges Integer] --- Ranges [1 +=+ 8,lbi 20] +-- = Quick start -- +-- Build ranges with the construction operators and combine them with @('<>')@: +-- +-- >>> (1 +=+ 5 :: Ranges Integer) <> (3 +=+ 8) +-- Ranges [1 +=+ 8] +-- +-- Test membership: +-- +-- >>> inRanges (1 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 5 +-- True +-- >>> inRanges (1 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 15 +-- False +-- +-- Use 'mconcat' to build from a list: +-- -- >>> mconcat [1 +=+ 5, 10 +=+ 15, 12 +=+ 20 :: Ranges Integer] -- Ranges [1 +=+ 5,10 +=+ 20] -- --- __When to use this module vs "Data.Range":__ +-- = Transforming ranges -- --- * Use "Data.Range" when working with @['Range' a]@ directly or calling individual --- set operations like 'union' and 'intersection'. --- * Use this module when you want 'Monoid' / 'Semigroup' semantics, need 'Functor' --- to map over all range boundaries, or are threading ranges through code that --- expects a 'Monoid' (e.g. 'mconcat', 'fold', writer-style accumulation). +-- 'Ranges' does not implement 'Functor'. Mapping a function over boundary +-- values is not a well-defined operation for half-infinite ranges: an +-- order-reversing function like @negate@ applied to 'lbi' would need to +-- produce 'ubi', but 'Functor' cannot express that structural flip. +-- +-- The idiomatic alternative is to __map the query value__, not the ranges. +-- Instead of converting boundaries to a new domain, convert incoming queries +-- back to the range's domain: +-- +-- @ +-- -- Unit conversion: test a Fahrenheit value against Celsius ranges +-- let safeTemp = 20 +=+ 37 :: Ranges Double -- defined in °C +-- let inSafeTemp f = inRanges safeTemp ((f - 32) * 5 / 9) +-- @ +-- +-- This is always correct regardless of whether the conversion is monotone, +-- never requires re-canonicalisation, and avoids the constructor-flip hazard. +-- +-- = Module guide +-- +-- * "Data.Ranges" — __start here__. 'Ranges' type, all set operations. +-- * "Data.Range" — deprecated re-export shim; use "Data.Ranges" instead. +-- * "Data.Range.Ord" — 'Data.Range.Ord.KeyRange' and 'Data.Range.Ord.SortedRange' for 'Ord'-requiring contexts. +-- * "Data.Range.Parser" — Parsec-based parser for range strings. +-- * "Data.Range.Algebra" — F-Algebra for deferred, efficient expression trees. module Data.Ranges ( + -- * Core types + Range(..), + Bound(..), + BoundType(..), -- * The Ranges type Ranges(unRanges), -- * Range creation @@ -36,11 +71,18 @@ ubi, ube, inf, - -- * Comparison functions + -- * Single-range predicates + inRange, + aboveRange, + belowRange, + rangesOverlap, + rangesAdjoin, + -- * Multi-range predicates inRanges, aboveRanges, belowRanges, -- * Set operations + mergeRanges, union, intersection, difference, @@ -54,16 +96,58 @@ -- >>> import Data.Ranges -- >>> import Data.Foldable (fold) -import Data.Semigroup -import qualified Data.Range as R +import Control.DeepSeq (NFData, rnf) --- | Smart constructor. Canonicalises the range list and pre-builds the cached --- lookup predicate. All internal paths that produce a 'Ranges' go through this. -mkRanges :: Ord a => [R.Range a] -> Ranges a +import Data.Range.Data +import Data.Range.Util + ( againstLowerBound, againstUpperBound, boundIsBetween, boundsOverlapType + , invertBound, takeEvenly + ) +import Data.Range.RangeInternal + ( loadRanges, exportRangeMerge, joinRM, buildSpanQuery + , RangeMerge(..) + ) +import qualified Data.Range.Operators as Op +import qualified Data.Range.Algebra as Alg + +-- --------------------------------------------------------------------------- +-- Internal helpers +-- --------------------------------------------------------------------------- + +-- | Build an O(log n) membership predicate from a canonical range list. +buildQuery :: Ord a => [Range a] -> a -> Bool +buildQuery rs = case loadRanges rs of + IRM -> const True + RM lb ub spans -> buildSpanQuery lb ub spans + +-- | Build an O(1) "above all ranges" predicate from the canonical range list. +-- The last element has the largest upper bound; if @a@ is above it, it is +-- above every range. If the last element is a 'LowerBoundRange' or +-- 'InfiniteRange', nothing can be above it, so the predicate returns 'False'. +buildAboveQuery :: Ord a => [Range a] -> a -> Bool +buildAboveQuery [] = const True +buildAboveQuery rs = aboveRange (last rs) + +-- | Build an O(1) "below all ranges" predicate from the canonical range list. +-- The first element has the smallest lower bound; if @a@ is below it, it is +-- below every range. If the first element is an 'UpperBoundRange' or +-- 'InfiniteRange', nothing can be below it, so the predicate returns 'False'. +buildBelowQuery :: Ord a => [Range a] -> a -> Bool +buildBelowQuery [] = const True +buildBelowQuery (r:_) = belowRange r + +-- | Smart constructor. Canonicalises the range list and pre-builds the +-- membership predicate. Every 'Ranges' value in this module is produced +-- through this function. +mkRanges :: Ord a => [Range a] -> Ranges a mkRanges xs = - let canonical = R.mergeRanges xs - in Ranges canonical (Just (R.inRanges canonical)) + let canonical = Alg.eval $ Alg.union (Alg.const []) (Alg.const xs) + in Ranges canonical (buildQuery canonical) (buildAboveQuery canonical) (buildBelowQuery canonical) +-- --------------------------------------------------------------------------- +-- The Ranges type +-- --------------------------------------------------------------------------- + -- $creation -- Each operator constructs a single-element 'Ranges'. Because 'Ranges' is a -- 'Semigroup', you can combine them directly with '<>': @@ -71,103 +155,209 @@ -- >>> (1 +=+ 5 :: Ranges Integer) <> (3 +=+ 8) -- Ranges [1 +=+ 8] -- --- The operators mirror those in "Data.Range" but return 'Ranges' instead of --- @'R.Range'@, so they compose naturally without wrapping and unwrapping. +-- The operators mirror those in "Data.Range.Operators" but return 'Ranges' +-- instead of 'Range', so they compose naturally without wrapping. -- | A set of ranges represented as a merged, canonical list of --- non-overlapping 'R.Range' values. +-- non-overlapping 'Range' values, with pre-built O(log n) membership, +-- O(1) above, and O(1) below predicates. -- --- The 'Semigroup' instance merges ranges on @('<>')@: +-- Construct values with the operators ('+=+', 'lbi', etc.) or with +-- 'mergeRanges'. Combine with @('<>')@ or 'mconcat'. -- +-- __Semigroup__: @('<>')@ computes the set union and merges the result into +-- canonical form. +-- -- >>> (1 +=+ 5 :: Ranges Integer) <> (3 +=+ 8) -- Ranges [1 +=+ 8] -- --- 'mempty' is the empty set (no ranges). 'mconcat' merges an entire list at once, --- which is more efficient than repeated @('<>')@: +-- __Monoid__: 'mempty' is the empty set. 'mconcat' merges an entire list in a +-- single pass, more efficiently than repeated @('<>')@: -- -- >>> mconcat [1 +=+ 5, 10 +=+ 15, 12 +=+ 20 :: Ranges Integer] -- Ranges [1 +=+ 5,10 +=+ 20] -- --- The 'Functor' instance maps a function over every boundary value in every range: --- --- >>> fmap (*2) (1 +=+ 5 :: Ranges Integer) --- Ranges [2 +=+ 10] --- --- Use 'unRanges' to extract the underlying list. Do not construct 'Ranges' --- directly; use the operators or set-operation functions so that the cached --- lookup structure is always kept consistent. +-- Use 'unRanges' to extract the underlying list. data Ranges a = Ranges - { unRanges :: [R.Range a] -- ^ The canonical (sorted, non-overlapping) range list. - , _rangesQuery :: Maybe (a -> Bool) -- ^ Cached O(log n) predicate; Nothing after 'fmap'. + { unRanges :: [Range a] -- ^ The canonical (sorted, non-overlapping) list. + , _rangesQuery :: a -> Bool -- ^ Cached O(log n) membership predicate. + , _aboveQuery :: a -> Bool -- ^ Cached O(1) "above all ranges" predicate. + , _belowQuery :: a -> Bool -- ^ Cached O(1) "below all ranges" predicate. } +-- | Two 'Ranges' values are equal when their canonical range lists are equal. +instance Eq a => Eq (Ranges a) where + a == b = unRanges a == unRanges b + instance Show a => Show (Ranges a) where - showsPrec i r = ((++) "Ranges ") . showsPrec i (unRanges r) + showsPrec i r = showParen (i > 10) $ ("Ranges " ++) . shows (unRanges r) --- | @('<>')@ computes the set union of two 'Ranges' and merges the result into --- canonical (non-overlapping) form. Associative, with 'mempty' as the identity. +-- | Forces the canonical range list; the cached predicate closure is not +-- forced (it is derived from the list and adds no new thunks). +instance NFData a => NFData (Ranges a) where + rnf r = rnf (unRanges r) + instance Ord a => Semigroup (Ranges a) where - (<>) a b = mkRanges $ unRanges a ++ unRanges b + (<>) a b = mkRanges (unRanges a ++ unRanges b) --- | 'mempty' is the empty set. 'mconcat' is more efficient than folding '<>' --- because it merges all ranges in a single pass. +-- | Evaluates a 'Alg.RangeExpr' tree whose leaves are 'Ranges' values, +-- producing a canonicalised 'Ranges' with a pre-built membership predicate. +-- +-- This is the primary evaluation target for user-facing algebra expressions. +-- The implementation converts leaves to @['Range' a]@ internally, folds the +-- tree in a single @'RangeMerge'@ pass (the same efficient path as the +-- @['Range' a]@ instance), then wraps the result with 'mkRanges'. +instance (Ord a) => Alg.RangeAlgebra (Ranges a) where + eval expr = mkRanges (Alg.eval (fmap unRanges expr)) + instance Ord a => Monoid (Ranges a) where - mempty = mkRanges [] - mappend a b = mkRanges $ unRanges a ++ unRanges b - mconcat = mkRanges . concat . fmap unRanges + mempty = mkRanges [] + mconcat = mkRanges . concatMap unRanges --- | Maps a function over every boundary value in every range. --- Note that mapping a non-monotonic function can produce ill-formed ranges --- (e.g. a span whose lower bound ends up greater than its upper bound). --- Use with care on ordered types. --- --- The cached lookup predicate cannot be pre-built here because 'Functor' does --- not allow an 'Ord' constraint. Calling 'inRanges' on the result will still --- pre-build the map on partial application via 'Data.Range.inRanges'. -instance Functor Ranges where - fmap f r = Ranges (fmap (fmap f) (unRanges r)) Nothing +-- --------------------------------------------------------------------------- +-- Construction operators +-- --------------------------------------------------------------------------- --- | Mathematically equivalent to @[x, y]@. See 'R.+=+' for details. +-- | Mathematically equivalent to @[x, y]@. See 'SpanRange' for the +-- underlying constructor. +-- +-- >>> 1 +=+ 5 :: Ranges Integer +-- Ranges [1 +=+ 5] (+=+) :: Ord a => a -> a -> Ranges a -(+=+) a b = mkRanges . pure $ (R.+=+) a b +(+=+) a b = mkRanges [(Op.+=+) a b] --- | Mathematically equivalent to @[x, y)@. See 'R.+=*' for details. +-- | Mathematically equivalent to @[x, y)@. +-- +-- >>> 1 +=* 5 :: Ranges Integer +-- Ranges [1 +=* 5] (+=*) :: Ord a => a -> a -> Ranges a -(+=*) a b = mkRanges . pure $ (R.+=*) a b +(+=*) a b = mkRanges [(Op.+=*) a b] --- | Mathematically equivalent to @(x, y]@. See 'R.*=+' for details. +-- | Mathematically equivalent to @(x, y]@. +-- +-- >>> 1 *=+ 5 :: Ranges Integer +-- Ranges [1 *=+ 5] (*=+) :: Ord a => a -> a -> Ranges a -(*=+) a b = mkRanges . pure $ (R.*=+) a b +(*=+) a b = mkRanges [(Op.*=+) a b] --- | Mathematically equivalent to @(x, y)@. See 'R.*=*' for details. +-- | Mathematically equivalent to @(x, y)@. +-- +-- >>> 1 *=* 5 :: Ranges Integer +-- Ranges [1 *=* 5] (*=*) :: Ord a => a -> a -> Ranges a -(*=*) a b = mkRanges . pure $ (R.*=*) a b +(*=*) a b = mkRanges [(Op.*=*) a b] --- | Mathematically equivalent to @[x, ∞)@. See 'R.lbi' for details. +-- | Mathematically equivalent to @[x, ∞)@. +-- +-- >>> lbi 5 :: Ranges Integer +-- Ranges [lbi 5] lbi :: Ord a => a -> Ranges a -lbi = mkRanges . pure . R.lbi +lbi = mkRanges . (:[]) . Op.lbi --- | Mathematically equivalent to @(x, ∞)@. See 'R.lbe' for details. +-- | Mathematically equivalent to @(x, ∞)@. lbe :: Ord a => a -> Ranges a -lbe = mkRanges . pure . R.lbe +lbe = mkRanges . (:[]) . Op.lbe --- | Mathematically equivalent to @(−∞, x]@. See 'R.ubi' for details. +-- | Mathematically equivalent to @(−∞, x]@. ubi :: Ord a => a -> Ranges a -ubi = mkRanges . pure . R.ubi +ubi = mkRanges . (:[]) . Op.ubi --- | Mathematically equivalent to @(−∞, x)@. See 'R.ube' for details. +-- | Mathematically equivalent to @(−∞, x)@. ube :: Ord a => a -> Ranges a -ube = mkRanges . pure . R.ube +ube = mkRanges . (:[]) . Op.ube --- | The infinite range, covering all values. See 'R.inf' for details. +-- | The infinite range, covering all values. inf :: Ord a => Ranges a -inf = mkRanges [R.inf] +inf = mkRanges [Op.inf] +-- --------------------------------------------------------------------------- +-- Single-range predicates +-- --------------------------------------------------------------------------- + +-- | Returns 'True' if the value falls within the single range. +-- Respects 'Inclusive' and 'Exclusive' bounds. +-- +-- See 'inRanges' for testing against a 'Ranges' collection. +-- +-- >>> inRange (SpanRange (Bound 1 Inclusive) (Bound 10 Inclusive)) (5 :: Integer) +-- True +-- >>> inRange (SpanRange (Bound 1 Inclusive) (Bound 10 Exclusive)) (10 :: Integer) +-- False +inRange :: Ord a => Range a -> a -> Bool +inRange (SingletonRange a) value = value == a +inRange (SpanRange x y) value = Overlap == boundIsBetween (Bound value Inclusive) (x, y) +inRange (LowerBoundRange lower) value = Overlap == againstLowerBound (Bound value Inclusive) lower +inRange (UpperBoundRange upper) value = Overlap == againstUpperBound (Bound value Inclusive) upper +inRange InfiniteRange _ = True + +-- | Returns 'True' if the value is strictly above (greater than the upper +-- bound of) the given range. +-- +-- >>> aboveRange (SpanRange (Bound 1 Inclusive) (Bound 5 Inclusive)) (6 :: Integer) +-- True +-- >>> aboveRange (LowerBoundRange (Bound 0 Inclusive)) (6 :: Integer) +-- False +aboveRange :: Ord a => Range a -> a -> Bool +aboveRange (SingletonRange a) value = value > a +aboveRange (SpanRange _ y) value = Overlap == againstLowerBound (Bound value Inclusive) (invertBound y) +aboveRange (LowerBoundRange _) _ = False +aboveRange (UpperBoundRange upper) value = Overlap == againstLowerBound (Bound value Inclusive) (invertBound upper) +aboveRange InfiniteRange _ = False + +-- | Returns 'True' if the value is strictly below (less than the lower +-- bound of) the given range. +-- +-- >>> belowRange (SpanRange (Bound 1 Inclusive) (Bound 5 Inclusive)) (0 :: Integer) +-- True +-- >>> belowRange (UpperBoundRange (Bound 6 Inclusive)) (0 :: Integer) +-- False +belowRange :: Ord a => Range a -> a -> Bool +belowRange (SingletonRange a) value = value < a +belowRange (SpanRange x _) value = Overlap == againstUpperBound (Bound value Inclusive) (invertBound x) +belowRange (LowerBoundRange lower) value = Overlap == againstUpperBound (Bound value Inclusive) (invertBound lower) +belowRange (UpperBoundRange _) _ = False +belowRange InfiniteRange _ = False + +-- | Returns 'True' if two ranges share at least one value. +-- +-- >>> rangesOverlap (SpanRange (Bound 1 Inclusive) (Bound 5 Inclusive)) (SpanRange (Bound 3 Inclusive) (Bound 7 Inclusive) :: Range Integer) +-- True +-- >>> rangesOverlap (SpanRange (Bound 1 Inclusive) (Bound 5 Exclusive)) (SpanRange (Bound 5 Inclusive) (Bound 7 Inclusive) :: Range Integer) +-- False +rangesOverlap :: Ord a => Range a -> Range a -> Bool +rangesOverlap a b = Overlap == rangesOverlapType a b + +-- | Returns 'True' if two ranges touch at a single exclusive boundary but +-- share no values. +-- +-- >>> rangesAdjoin (SpanRange (Bound 1 Inclusive) (Bound 5 Exclusive)) (SpanRange (Bound 5 Inclusive) (Bound 7 Inclusive) :: Range Integer) +-- True +-- >>> rangesAdjoin (SpanRange (Bound 1 Inclusive) (Bound 5 Inclusive)) (SpanRange (Bound 3 Inclusive) (Bound 7 Inclusive) :: Range Integer) +-- False +rangesAdjoin :: Ord a => Range a -> Range a -> Bool +rangesAdjoin a b = Adjoin == rangesOverlapType a b + +rangesOverlapType :: Ord a => Range a -> Range a -> OverlapType +rangesOverlapType (SingletonRange a) x = + rangesOverlapType (SpanRange (Bound a Inclusive) (Bound a Inclusive)) x +rangesOverlapType (SpanRange x y) (SpanRange a b) = boundsOverlapType (x, y) (a, b) +rangesOverlapType (SpanRange _ y) (LowerBoundRange lower) = againstLowerBound y lower +rangesOverlapType (SpanRange x _) (UpperBoundRange upper) = againstUpperBound x upper +rangesOverlapType (LowerBoundRange _) (LowerBoundRange _) = Overlap +rangesOverlapType (LowerBoundRange lo) (UpperBoundRange up) = againstUpperBound lo up +rangesOverlapType (UpperBoundRange _) (UpperBoundRange _) = Overlap +rangesOverlapType InfiniteRange _ = Overlap +rangesOverlapType a b = rangesOverlapType b a + +-- --------------------------------------------------------------------------- +-- Multi-range predicates +-- --------------------------------------------------------------------------- + -- | Returns 'True' if the value falls within any of the given ranges. -- --- The lookup structure is pre-built when the 'Ranges' value is constructed, --- so each membership test is O(log n) where n is the number of spans. --- Partial application is idiomatic: +-- The membership predicate is pre-built when the 'Ranges' value is +-- constructed, so each call is O(log n) in the number of spans. Partial +-- application is idiomatic: -- -- @ -- let memberOf = inRanges myRanges @@ -179,69 +369,111 @@ -- >>> inRanges (1 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 15 -- False inRanges :: Ord a => Ranges a -> a -> Bool -inRanges r = case _rangesQuery r of - Just f -> f - Nothing -> R.inRanges (unRanges r) +inRanges = _rangesQuery --- | Returns 'True' if the value is strictly above (greater than the upper --- bound of) all of the given ranges. +-- | Returns 'True' if the value is strictly above all of the given ranges. -- +-- This predicate is O(1): the answer is determined by the last element of the +-- canonical range list (which has the largest upper bound), cached at +-- construction time. +-- -- >>> aboveRanges (1 +=+ 5 <> 10 +=+ 15 :: Ranges Integer) 20 -- True -- >>> aboveRanges (1 +=+ 5 <> lbi 10 :: Ranges Integer) 20 -- False -aboveRanges :: (Ord a) => Ranges a -> a -> Bool -aboveRanges r a = R.aboveRanges (unRanges r) a +aboveRanges :: Ord a => Ranges a -> a -> Bool +aboveRanges = _aboveQuery --- | Returns 'True' if the value is strictly below (less than the lower --- bound of) all of the given ranges. +-- | Returns 'True' if the value is strictly below all of the given ranges. -- +-- This predicate is O(1): the answer is determined by the first element of the +-- canonical range list (which has the smallest lower bound), cached at +-- construction time. +-- -- >>> belowRanges (5 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 1 -- True -- >>> belowRanges (ubi 10 <> 20 +=+ 30 :: Ranges Integer) 1 -- False -belowRanges :: (Ord a) => Ranges a -> a -> Bool -belowRanges r a = R.belowRanges (unRanges r) a +belowRanges :: Ord a => Ranges a -> a -> Bool +belowRanges = _belowQuery --- | Set union of two 'Ranges'. The output is in merged canonical form. --- Equivalent to @('<>')@. -union :: (Ord a) => Ranges a -> Ranges a -> Ranges a -union a b = mkRanges $ R.union (unRanges a) (unRanges b) +-- --------------------------------------------------------------------------- +-- Set operations +-- --------------------------------------------------------------------------- --- | Set intersection of two 'Ranges'. Returns only values present in both. +-- | Canonicalise a raw list of 'Range' values into a 'Ranges'. Overlapping +-- ranges are merged; the result is sorted and non-overlapping. -- +-- >>> mergeRanges [LowerBoundRange (Bound 12 Inclusive), SpanRange (Bound 1 Inclusive) (Bound 10 Inclusive), SpanRange (Bound 5 Inclusive) (Bound 15 Inclusive) :: Range Integer] +-- Ranges [lbi 1] +mergeRanges :: Ord a => [Range a] -> Ranges a +mergeRanges = mkRanges + +-- | Set union. Equivalent to @('<>')@. +-- +-- >>> union (1 +=+ 10) (5 +=+ 15 :: Ranges Integer) +-- Ranges [1 +=+ 15] +union :: Ord a => Ranges a -> Ranges a -> Ranges a +union a b = mkRanges $ Alg.eval $ + Alg.union (Alg.const (unRanges a)) (Alg.const (unRanges b)) + +-- | Set intersection. Returns only values present in both. +-- -- >>> intersection (1 +=+ 10) (5 +=+ 15 :: Ranges Integer) -- Ranges [5 +=+ 10] -intersection :: (Ord a) => Ranges a -> Ranges a -> Ranges a -intersection a b = mkRanges $ R.intersection (unRanges a) (unRanges b) +intersection :: Ord a => Ranges a -> Ranges a -> Ranges a +intersection a b = mkRanges $ Alg.eval $ + Alg.intersection (Alg.const (unRanges a)) (Alg.const (unRanges b)) --- | Set difference: values in the first 'Ranges' that are not in the second. +-- | Set difference: values in the first 'Ranges' not in the second. -- -- >>> difference (1 +=+ 10) (5 +=+ 15 :: Ranges Integer) -- Ranges [1 +=* 5] -difference :: (Ord a) => Ranges a -> Ranges a -> Ranges a -difference a b = mkRanges $ R.difference (unRanges a) (unRanges b) +difference :: Ord a => Ranges a -> Ranges a -> Ranges a +difference a b = mkRanges $ Alg.eval $ + Alg.difference (Alg.const (unRanges a)) (Alg.const (unRanges b)) --- | Returns the complement of the given 'Ranges': all values /not/ covered. --- Note that @'invert' . 'invert' == 'id'@. -invert :: (Ord a) => Ranges a -> Ranges a -invert = mkRanges . R.invert . unRanges +-- | Complement: all values /not/ covered by the given 'Ranges'. +-- @'invert' . 'invert' == 'id'@. +-- +-- >>> invert (1 +=* 10 <> 15 *=+ 20 :: Ranges Integer) +-- Ranges [ube 1,10 +=+ 15,lbe 20] +invert :: Ord a => Ranges a -> Ranges a +invert = mkRanges . Alg.eval . Alg.invert . Alg.const . unRanges --- | Instantiates all values covered by the ranges as a list. --- __Warning:__ This is a convenience function and is not efficient. Prefer --- membership checks with 'inRanges' where possible. Combine with 'take' to --- avoid evaluating infinite ranges. +-- --------------------------------------------------------------------------- +-- Enumerable methods +-- --------------------------------------------------------------------------- + +-- | Instantiate all values covered by the ranges as a list. +-- __Warning:__ not efficient. Prefer 'inRanges' for membership tests. +-- Combine with 'take' to avoid evaluating infinite ranges. -- +-- >>> take 5 . fromRanges $ (1 +=+ 10 :: Ranges Integer) +-- [1,2,3,4,5] +-- -- >>> take 6 . fromRanges $ (1 +=+ 3 :: Ranges Integer) <> (10 +=+ 12) -- [1,10,2,11,3,12] fromRanges :: (Ord a, Enum a) => Ranges a -> [a] -fromRanges = R.fromRanges . unRanges +fromRanges = takeEvenly . fmap fromRange . unRanges + where + fromRange (SingletonRange x) = [x] + fromRange (SpanRange (Bound a aType) (Bound b bType)) = + [ (if aType == Inclusive then a else succ a) + .. (if bType == Inclusive then b else pred b) ] + fromRange (LowerBoundRange (Bound x xType)) = + iterate succ (if xType == Inclusive then x else succ x) + fromRange (UpperBoundRange (Bound x xType)) = + iterate pred (if xType == Inclusive then x else pred x) + fromRange InfiniteRange = + zero : takeEvenly [iterate succ (succ zero), iterate pred (pred zero)] + where zero = toEnum 0 --- | Joins adjacent ranges that are contiguous for 'Enum' types. For example, --- @[1 +=+ 5, 6 +=+ 10]@ can be collapsed to @[1 +=+ 10]@ for 'Integer' --- because there is no integer between 5 and 6. +-- | Join adjacent ranges that are contiguous for 'Enum' types. +-- For example, @[1 +=+ 5, 6 +=+ 10]@ collapses to @[1 +=+ 10]@ for +-- 'Integer' because there is no integer between 5 and 6. -- -- >>> joinRanges (mconcat [1 +=+ 5, 6 +=+ 10] :: Ranges Integer) -- Ranges [1 +=+ 10] joinRanges :: (Ord a, Enum a) => Ranges a -> Ranges a -joinRanges = mkRanges . R.joinRanges . unRanges +joinRanges = mkRanges . exportRangeMerge . joinRM . loadRanges . unRanges diff --git a/Test/Generators.hs b/Test/Generators.hs --- a/Test/Generators.hs +++ b/Test/Generators.hs @@ -7,9 +7,12 @@ import Test.QuickCheck import Control.Monad (liftM) -import Data.Range +import Data.Ranges import qualified Data.Range.Algebra as Alg +instance Arbitrary BoundType where + arbitrary = elements [Inclusive, Exclusive] + instance (Num a, Integral a, Ord a, Enum a) => Arbitrary (Range a) where arbitrary = oneof [ generateSingleton @@ -21,13 +24,24 @@ where generateSingleton = liftM SingletonRange arbitrarySizedIntegral generateSpan = do - first <- arbitrarySizedIntegral - second <- arbitrarySizedIntegral `suchThat` (> first) - return $ first +=+ second - generateLowerBound = liftM lbi arbitrarySizedIntegral - generateUpperBound = liftM ubi arbitrarySizedIntegral + first <- arbitrarySizedIntegral + second <- arbitrarySizedIntegral `suchThat` (> first) + loBound <- arbitrary + hiBound <- arbitrary + return $ SpanRange (Bound first loBound) (Bound second hiBound) + generateLowerBound = do + x <- arbitrarySizedIntegral + bound <- arbitrary + return $ LowerBoundRange (Bound x bound) + generateUpperBound = do + x <- arbitrarySizedIntegral + bound <- arbitrary + return $ UpperBoundRange (Bound x bound) generateInfiniteRange :: Gen (Range a) generateInfiniteRange = return InfiniteRange + +instance (Num a, Integral a, Ord a, Enum a) => Arbitrary (Ranges a) where + arbitrary = mergeRanges <$> listOf arbitrary instance (Num a, Integral a, Ord a, Enum a) => Arbitrary (Alg.RangeExpr [Range a]) where arbitrary = frequency diff --git a/Test/Range.hs b/Test/Range.hs --- a/Test/Range.hs +++ b/Test/Range.hs @@ -4,19 +4,20 @@ module Main where -import Test.Framework (defaultMain, testGroup) +import Test.Framework (Test, defaultMain, testGroup) import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 import System.Random -import Data.Range +import Data.Ranges import qualified Data.Range.Algebra as Alg import Test.RangeMerge import Test.RangeLaws import Test.RangeParser import Test.RangeOrd +import Test.RangeBounds import Test.Generators () data UnequalPair a = UnequalPair (a, a) @@ -50,9 +51,10 @@ prop_infinite_range_contains_everything :: Integer -> Bool prop_infinite_range_contains_everything = inRange InfiniteRange +tests_inRange :: Test tests_inRange = testGroup "inRange Function" [ testProperty "equal singletons in range" prop_singleton_in_range - , testProperty "unequal singletons not in range" prop_singleton_not_in_range + , testProperty "unequal singletons not in range" (prop_singleton_not_in_range :: UnequalPair Integer -> Bool) , testProperty "spans contain values in their middles" prop_span_contains , testProperty "infinite ranges contain everything" prop_infinite_range_contains_everything ] @@ -64,10 +66,11 @@ -- (1, 3) intersection (3, 4) = (3, 3) -- ((1, 3) intersection (3, 4)) union (3, 4) => (3, 4) -prop_in_range_out_of_range_after_invert :: (Integer, [Range Integer]) -> Bool +prop_in_range_out_of_range_after_invert :: (Integer, Ranges Integer) -> Bool prop_in_range_out_of_range_after_invert (point, ranges) = (inRanges ranges point) /= (inRanges (invert ranges) point) +test_ranges_invert :: Test test_ranges_invert = testGroup "invert function for ranges" [ testProperty "element in range is now out of range after invert" prop_in_range_out_of_range_after_invert ] @@ -75,14 +78,15 @@ prop_equivalence_eval_and_evalPredicate :: ([Integer], Alg.RangeExpr [Range Integer]) -> Bool prop_equivalence_eval_and_evalPredicate (points, expr) = actual == expected where - actual = map (inRanges $ Alg.eval expr) points - expected = map (Alg.eval $ fmap inRanges expr) points + actual = map (inRanges (mergeRanges (Alg.eval expr))) points + expected = map (Alg.eval (fmap (inRanges . mergeRanges) expr)) points +test_algebra_equivalence :: Test test_algebra_equivalence = testGroup "algebra equivalence" [ testProperty "eval and evalPredicate" prop_equivalence_eval_and_evalPredicate ] ---tests :: [Test] +tests :: [Test] tests = [ tests_inRange , test_ranges_invert @@ -92,5 +96,7 @@ ++ rangeLawTestCases ++ rangeParserTestCases ++ rangeOrdTestCases + ++ rangeBoundsTestCases +main :: IO () main = defaultMain tests diff --git a/Test/RangeBounds.hs b/Test/RangeBounds.hs new file mode 100644 --- /dev/null +++ b/Test/RangeBounds.hs @@ -0,0 +1,123 @@ +module Test.RangeBounds + ( rangeBoundsTestCases + ) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Positive(..), Property, (==>)) + +import Data.Ranges +import Test.Generators () + +-- --------------------------------------------------------------------------- +-- inRange: exclusive vs inclusive endpoint behaviour +-- --------------------------------------------------------------------------- + +-- Exclusive lower bound: the boundary value itself is NOT in the range. +prop_exclusive_lower_excludes_endpoint :: Positive Integer -> Bool +prop_exclusive_lower_excludes_endpoint (Positive x) = + not $ inRange (SpanRange (Bound x Exclusive) (Bound (x + 10) Inclusive)) x + +-- Inclusive lower bound: the boundary value IS in the range. +prop_inclusive_lower_includes_endpoint :: Positive Integer -> Bool +prop_inclusive_lower_includes_endpoint (Positive x) = + inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Inclusive)) x + +-- Exclusive upper bound: the boundary value itself is NOT in the range. +prop_exclusive_upper_excludes_endpoint :: Positive Integer -> Bool +prop_exclusive_upper_excludes_endpoint (Positive x) = + not $ inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Exclusive)) (x + 10) + +-- Inclusive upper bound: the boundary value IS in the range. +prop_inclusive_upper_includes_endpoint :: Positive Integer -> Bool +prop_inclusive_upper_includes_endpoint (Positive x) = + inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Inclusive)) (x + 10) + +test_inrange_endpoints :: Test +test_inrange_endpoints = testGroup "inRange endpoint inclusion" + [ testProperty "exclusive lower bound excludes endpoint" prop_exclusive_lower_excludes_endpoint + , testProperty "inclusive lower bound includes endpoint" prop_inclusive_lower_includes_endpoint + , testProperty "exclusive upper bound excludes endpoint" prop_exclusive_upper_excludes_endpoint + , testProperty "inclusive upper bound includes endpoint" prop_inclusive_upper_includes_endpoint + ] + +-- --------------------------------------------------------------------------- +-- aboveRange / belowRange: exclusive bound semantics +-- --------------------------------------------------------------------------- + +-- A value equal to an exclusive upper bound is ABOVE the range +-- (the range ends strictly before that value). +prop_above_exclusive_upper :: Positive Integer -> Bool +prop_above_exclusive_upper (Positive x) = + aboveRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Exclusive)) (x + 10) + +-- A value equal to an exclusive lower bound is BELOW the range +-- (the range starts strictly after that value). +prop_below_exclusive_lower :: Positive Integer -> Bool +prop_below_exclusive_lower (Positive x) = + belowRange (SpanRange (Bound x Exclusive) (Bound (x + 10) Inclusive)) x + +test_above_below_exclusive :: Test +test_above_below_exclusive = testGroup "aboveRange/belowRange with exclusive bounds" + [ testProperty "value at exclusive upper bound is above range" prop_above_exclusive_upper + , testProperty "value at exclusive lower bound is below range" prop_below_exclusive_lower + ] + +-- --------------------------------------------------------------------------- +-- Half-infinite ranges: exclusive bounds +-- --------------------------------------------------------------------------- + +-- lbe: exclusive lower bound does not include the endpoint but includes succ +prop_lbe_excludes_endpoint :: Integer -> Bool +prop_lbe_excludes_endpoint x = + not (inRange (LowerBoundRange (Bound x Exclusive)) x) + && inRange (LowerBoundRange (Bound x Exclusive)) (x + 1) + +-- ube: exclusive upper bound does not include the endpoint but includes pred +prop_ube_excludes_endpoint :: Integer -> Bool +prop_ube_excludes_endpoint x = + not (inRange (UpperBoundRange (Bound x Exclusive)) x) + && inRange (UpperBoundRange (Bound x Exclusive)) (x - 1) + +test_halfinfinte_exclusive :: Test +test_halfinfinte_exclusive = testGroup "half-infinite exclusive bounds" + [ testProperty "lbe excludes endpoint, includes successor" prop_lbe_excludes_endpoint + , testProperty "ube excludes endpoint, includes predecessor" prop_ube_excludes_endpoint + ] + +-- --------------------------------------------------------------------------- +-- Mutual exclusion: belowRanges / inRanges / aboveRanges +-- --------------------------------------------------------------------------- + +-- For any point and any non-empty Ranges, no two of below/in/above can be +-- simultaneously true. (A point in the gap between disjoint ranges is none +-- of the three — that is also correct.) +-- +-- The non-empty guard is necessary: for Ranges [], belowRanges and aboveRanges +-- both return True vacuously (there are no ranges to fail to be above/below), +-- so the mutual-exclusion invariant only holds for non-empty range sets. +prop_below_in_above_mutually_exclusive :: (Integer, Ranges Integer) -> Property +prop_below_in_above_mutually_exclusive (x, rs) = + not (null (unRanges rs)) ==> + let b = belowRanges rs x + i = inRanges rs x + a = aboveRanges rs x + in not (b && i) && not (a && i) && not (b && a) + +test_partition :: Test +test_partition = testGroup "below/in/above mutual exclusion" + [ testProperty "at most one of belowRanges/inRanges/aboveRanges holds" + prop_below_in_above_mutually_exclusive + ] + +-- --------------------------------------------------------------------------- +-- Export +-- --------------------------------------------------------------------------- + +rangeBoundsTestCases :: [Test] +rangeBoundsTestCases = + [ test_inrange_endpoints + , test_above_below_exclusive + , test_halfinfinte_exclusive + , test_partition + ] diff --git a/Test/RangeLaws.hs b/Test/RangeLaws.hs --- a/Test/RangeLaws.hs +++ b/Test/RangeLaws.hs @@ -3,37 +3,33 @@ ) where import Test.Framework (Test, testGroup) -import Test.QuickCheck +import Test.QuickCheck () import Test.Framework.Providers.QuickCheck2 -import Data.Range +import Data.Ranges import Test.Generators () -- --------------------------------------------------------------------------- -- Helpers -- --------------------------------------------------------------------------- --- Sort before comparing so that order differences don't cause false failures. --- mergeRanges produces a canonical form, so we use it to normalise both sides. -canonical :: Ord a => [Range a] -> [Range a] -canonical = mergeRanges - -eq :: (Ord a) => [Range a] -> [Range a] -> Bool -eq a b = canonical a == canonical b +-- Ranges is always in canonical form; compare the underlying lists. +eq :: Ord a => Ranges a -> Ranges a -> Bool +eq a b = unRanges a == unRanges b -- --------------------------------------------------------------------------- -- Idempotency -- --------------------------------------------------------------------------- -prop_mergeRanges_idempotent :: [Range Integer] -> Bool +prop_mergeRanges_idempotent :: Ranges Integer -> Bool prop_mergeRanges_idempotent xs = - mergeRanges (mergeRanges xs) == mergeRanges xs + mergeRanges (unRanges xs) `eq` xs -prop_union_idempotent :: [Range Integer] -> Bool +prop_union_idempotent :: Ranges Integer -> Bool prop_union_idempotent xs = union xs xs `eq` xs -prop_intersection_idempotent :: [Range Integer] -> Bool +prop_intersection_idempotent :: Ranges Integer -> Bool prop_intersection_idempotent xs = intersection xs xs `eq` xs @@ -48,11 +44,11 @@ -- Commutativity -- --------------------------------------------------------------------------- -prop_union_commutative :: ([Range Integer], [Range Integer]) -> Bool +prop_union_commutative :: (Ranges Integer, Ranges Integer) -> Bool prop_union_commutative (a, b) = union a b `eq` union b a -prop_intersection_commutative :: ([Range Integer], [Range Integer]) -> Bool +prop_intersection_commutative :: (Ranges Integer, Ranges Integer) -> Bool prop_intersection_commutative (a, b) = intersection a b `eq` intersection b a @@ -66,11 +62,11 @@ -- Associativity -- --------------------------------------------------------------------------- -prop_union_associative :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +prop_union_associative :: (Ranges Integer, Ranges Integer, Ranges Integer) -> Bool prop_union_associative (a, b, c) = union (union a b) c `eq` union a (union b c) -prop_intersection_associative :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +prop_intersection_associative :: (Ranges Integer, Ranges Integer, Ranges Integer) -> Bool prop_intersection_associative (a, b, c) = intersection (intersection a b) c `eq` intersection a (intersection b c) @@ -85,12 +81,12 @@ -- --------------------------------------------------------------------------- prop_intersection_distributes_over_union - :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool + :: (Ranges Integer, Ranges Integer, Ranges Integer) -> Bool prop_intersection_distributes_over_union (a, b, c) = intersection a (union b c) `eq` union (intersection a b) (intersection a c) prop_union_distributes_over_intersection - :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool + :: (Ranges Integer, Ranges Integer, Ranges Integer) -> Bool prop_union_distributes_over_intersection (a, b, c) = union a (intersection b c) `eq` intersection (union a b) (union a c) @@ -106,32 +102,28 @@ -- Identity laws -- --------------------------------------------------------------------------- --- The empty range list acts as the identity for union -prop_union_identity_empty :: [Range Integer] -> Bool +prop_union_identity_empty :: Ranges Integer -> Bool prop_union_identity_empty xs = - union xs [] `eq` xs + union xs mempty `eq` xs --- InfiniteRange acts as the identity for intersection -prop_intersection_identity_infinite :: [Range Integer] -> Bool +prop_intersection_identity_infinite :: Ranges Integer -> Bool prop_intersection_identity_infinite xs = - intersection xs [InfiniteRange] `eq` xs + intersection xs inf `eq` xs --- Union with InfiniteRange absorbs everything -prop_union_absorb_infinite :: [Range Integer] -> Bool +prop_union_absorb_infinite :: Ranges Integer -> Bool prop_union_absorb_infinite xs = - union xs [InfiniteRange] `eq` [InfiniteRange] + union xs inf `eq` inf --- Intersection with empty absorbs everything -prop_intersection_absorb_empty :: [Range Integer] -> Bool +prop_intersection_absorb_empty :: Ranges Integer -> Bool prop_intersection_absorb_empty xs = - intersection xs [] `eq` [] + intersection xs mempty `eq` mempty test_identity_absorption :: Test test_identity_absorption = testGroup "identity and absorption" - [ testProperty "union with [] is identity" prop_union_identity_empty - , testProperty "intersection with InfiniteRange is identity" prop_intersection_identity_infinite - , testProperty "union with InfiniteRange absorbs" prop_union_absorb_infinite - , testProperty "intersection with [] absorbs" prop_intersection_absorb_empty + [ testProperty "union with mempty is identity" prop_union_identity_empty + , testProperty "intersection with inf is identity" prop_intersection_identity_infinite + , testProperty "union with inf absorbs" prop_union_absorb_infinite + , testProperty "intersection with mempty absorbs" prop_intersection_absorb_empty ] -- --------------------------------------------------------------------------- @@ -139,7 +131,7 @@ -- --------------------------------------------------------------------------- prop_difference_eq_intersection_invert - :: ([Range Integer], [Range Integer]) -> Bool + :: (Ranges Integer, Ranges Integer) -> Bool prop_difference_eq_intersection_invert (a, b) = difference a b `eq` intersection a (invert b) @@ -153,7 +145,7 @@ -- Double inversion -- --------------------------------------------------------------------------- -prop_invert_twice_identity :: [Range Integer] -> Bool +prop_invert_twice_identity :: Ranges Integer -> Bool prop_invert_twice_identity xs = invert (invert xs) `eq` xs diff --git a/Test/RangeMerge.hs b/Test/RangeMerge.hs --- a/Test/RangeMerge.hs +++ b/Test/RangeMerge.hs @@ -5,7 +5,7 @@ ( rangeMergeTestCases ) where -import Test.Framework (testGroup) +import Test.Framework (Test, testGroup) import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 @@ -66,6 +66,7 @@ prop_export_load_is_identity :: RangeMerge Integer -> Bool prop_export_load_is_identity x = loadRanges (exportRangeMerge x) == x +test_loadRM :: Test test_loadRM = testGroup "loadRanges function" [ testProperty "loading export results in identity" prop_export_load_is_identity ] @@ -73,6 +74,7 @@ prop_invert_twice_is_identity :: RangeMerge Integer -> Bool prop_invert_twice_is_identity x = (invertRM . invertRM $ x) == x +test_invertRM :: Test test_invertRM = testGroup "invertRM function" [ testProperty "inverting twice results in identity" prop_invert_twice_is_identity ] @@ -83,6 +85,7 @@ prop_union_with_infinite_is_infinite :: RangeMerge Integer -> Bool prop_union_with_infinite_is_infinite rm = (rm `unionRangeMerges` IRM) == IRM +test_unionRM :: Test test_unionRM = testGroup "unionRangeMerges function" [ testProperty "Union with empty is self" prop_union_with_empty_is_self , testProperty "Union with infinite is infinite" prop_union_with_infinite_is_infinite @@ -96,6 +99,7 @@ prop_intersection_with_infinite_is_self rm = (rm `intersectionRangeMerges` IRM) == rm +test_intersectionRM :: Test test_intersectionRM = testGroup "intersectionRangeMerges function" [ testProperty "Intersection with empty is empty" prop_intersection_with_empty_is_empty , testProperty "Intersection with infinite is self" prop_intersection_with_infinite_is_self @@ -109,11 +113,13 @@ prop_demorgans_law_two (a, b) = (invertRM (a `intersectionRangeMerges` b)) == ((invertRM a) `unionRangeMerges` (invertRM b)) +test_complex_laws :: Test test_complex_laws = testGroup "complex set theory rules" [ testProperty "DeMorgan Part 1: not (a or b) == (not a) and (not b)" (verboseShrinking (withMaxSuccess 10000 prop_demorgans_law_one)) , testProperty "DeMorgan Part 2: not (a and b) == (not a) or (not b)" (verboseShrinking (withMaxSuccess 10000 prop_demorgans_law_two)) ] +rangeMergeTestCases :: [Test] rangeMergeTestCases = [ test_loadRM , test_invertRM diff --git a/Test/RangeOrd.hs b/Test/RangeOrd.hs --- a/Test/RangeOrd.hs +++ b/Test/RangeOrd.hs @@ -2,20 +2,44 @@ ( rangeOrdTestCases ) where -import Data.List (sort, sortOn) +import Data.List (sortOn) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck +import Test.QuickCheck () -import Data.Range +import Data.Ranges import Data.Range.Ord import Test.Generators () -- --------------------------------------------------------------------------- +-- Local helpers — the module-level operators now return Ranges, not Range +-- --------------------------------------------------------------------------- + +-- | Inclusive span Range +spanI :: a -> a -> Range a +spanI a b = SpanRange (Bound a Inclusive) (Bound b Inclusive) + +-- | Lower bound inclusive Range +lbiR :: a -> Range a +lbiR x = LowerBoundRange (Bound x Inclusive) + +-- | Upper bound inclusive Range +ubiR :: a -> Range a +ubiR x = UpperBoundRange (Bound x Inclusive) + +-- | Upper bound exclusive Range +ubeR :: a -> Range a +ubeR x = UpperBoundRange (Bound x Exclusive) + +-- | Infinite Range +infR :: Range a +infR = InfiniteRange + +-- --------------------------------------------------------------------------- -- Helpers -- --------------------------------------------------------------------------- @@ -35,19 +59,19 @@ -- UpperBoundRange < InfiniteRange prop_key_constructor_singleton_lt_span :: Bool prop_key_constructor_singleton_lt_span = - KeyRange (SingletonRange (0 :: Integer)) < KeyRange (0 +=+ 0) + KeyRange (SingletonRange (0 :: Integer)) < KeyRange (spanI 0 0) prop_key_constructor_span_lt_lower :: Bool prop_key_constructor_span_lt_lower = - KeyRange (0 +=+ (0 :: Integer)) < KeyRange (lbi 0) + KeyRange (spanI 0 (0 :: Integer)) < KeyRange (lbiR 0) prop_key_constructor_lower_lt_upper :: Bool prop_key_constructor_lower_lt_upper = - KeyRange (lbi (0 :: Integer)) < KeyRange (ubi 0) + KeyRange (lbiR (0 :: Integer)) < KeyRange (ubiR 0) prop_key_constructor_upper_lt_infinite :: Bool prop_key_constructor_upper_lt_infinite = - KeyRange (ubi (0 :: Integer)) < KeyRange (inf :: Range Integer) + KeyRange (ubiR (0 :: Integer)) < KeyRange (infR :: Range Integer) -- Within the same constructor, compare by fields prop_key_singletons_by_value :: Bool @@ -56,23 +80,23 @@ prop_key_spans_by_lower_first :: Bool prop_key_spans_by_lower_first = - KeyRange ((1 :: Integer) +=+ 10) < KeyRange (2 +=+ 10) + KeyRange (spanI (1 :: Integer) 10) < KeyRange (spanI 2 10) prop_key_spans_by_upper_on_equal_lower :: Bool prop_key_spans_by_upper_on_equal_lower = - KeyRange ((1 :: Integer) +=+ 5) < KeyRange (1 +=+ 10) + KeyRange (spanI (1 :: Integer) 5) < KeyRange (spanI 1 10) prop_key_lower_bounds_by_value :: Bool prop_key_lower_bounds_by_value = - KeyRange (lbi (1 :: Integer)) < KeyRange (lbi 2) + KeyRange (lbiR (1 :: Integer)) < KeyRange (lbiR 2) prop_key_upper_bounds_by_value :: Bool prop_key_upper_bounds_by_value = - KeyRange (ubi (1 :: Integer)) < KeyRange (ubi 2) + KeyRange (ubiR (1 :: Integer)) < KeyRange (ubiR 2) prop_key_infinite_eq_infinite :: Bool prop_key_infinite_eq_infinite = - compare (KeyRange (inf :: Range Integer)) (KeyRange inf) == EQ + compare (KeyRange (infR :: Range Integer)) (KeyRange infR) == EQ test_keyrange_unit :: Test test_keyrange_unit = testGroup "KeyRange unit" @@ -132,11 +156,11 @@ -- Ranges with NegInfinity lower bound sort before those with a finite lower bound prop_sorted_upper_before_span :: Bool prop_sorted_upper_before_span = - SortedRange (ubi (0 :: Integer)) < SortedRange (lbi 0) + SortedRange (ubiR (0 :: Integer)) < SortedRange (lbiR 0) prop_sorted_infinite_before_lower :: Bool prop_sorted_infinite_before_lower = - SortedRange (inf :: Range Integer) < SortedRange (lbi 1) + SortedRange (infR :: Range Integer) < SortedRange (lbiR 1) -- Spans ordered by lower bound prop_sorted_singletons_by_value :: Bool @@ -145,24 +169,24 @@ prop_sorted_spans_by_lower :: Bool prop_sorted_spans_by_lower = - SortedRange ((1 :: Integer) +=+ 10) < SortedRange (2 +=+ 10) + SortedRange (spanI (1 :: Integer) 10) < SortedRange (spanI 2 10) -- When lower bounds are equal, tiebreak by upper bound (smaller upper = comes first) prop_sorted_tiebreak_by_upper :: Bool prop_sorted_tiebreak_by_upper = - SortedRange ((1 :: Integer) +=+ 5) < SortedRange (1 +=+ 10) + SortedRange (spanI (1 :: Integer) 5) < SortedRange (spanI 1 10) -- InfiniteRange and UpperBoundRange both start at -∞; -- InfiniteRange ends at +∞ so it sorts after a finite UpperBoundRange prop_sorted_upper_before_infinite :: Bool prop_sorted_upper_before_infinite = - SortedRange (ubi (0 :: Integer)) < SortedRange (inf :: Range Integer) + SortedRange (ubiR (0 :: Integer)) < SortedRange (infR :: Range Integer) -- The canonical display order: UpperBoundRange, SpanRange, LowerBoundRange prop_sorted_display_order :: Bool prop_sorted_display_order = - sortOn SortedRange [lbi 10, (1 :: Integer) +=+ 5, ube 0] - == [ube 0, 1 +=+ 5, lbi 10] + sortOn SortedRange [lbiR 10, spanI (1 :: Integer) 5, ubeR 0] + == [ubeR 0, spanI 1 5, lbiR 10] -- SingletonRange 5 and 5 +=+ 5 occupy the same position so compare as EQ prop_sorted_singleton_eq_degenerate_span :: Bool diff --git a/Test/RangeParser.hs b/Test/RangeParser.hs --- a/Test/RangeParser.hs +++ b/Test/RangeParser.hs @@ -6,20 +6,21 @@ import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 -import Data.Range +import Data.Ranges import Data.Range.Parser -- --------------------------------------------------------------------------- -- Helpers -- --------------------------------------------------------------------------- +-- | Check that parsing @input@ produces a 'Ranges' equal to @mergeRanges expected@. shouldParse :: String -> [Range Integer] -> Bool shouldParse input expected = case parseRanges input of - Right result -> result == expected + Right result -> result == mergeRanges expected Left _ -> False shouldFail :: String -> Bool -shouldFail input = case (parseRanges input :: Either ParseError [Range Integer]) of +shouldFail input = case (parseRanges input :: Either ParseError (Ranges Integer)) of Left _ -> True Right _ -> False @@ -27,9 +28,6 @@ -- Haddock example tests -- --------------------------------------------------------------------------- --- The example from the module documentation: --- >>> parseRanges "-5,8-10,13-15,20-" :: Either ParseError [Range Integer] --- Right [UpperBoundRange 5,SpanRange 8 10,SpanRange 13 15,LowerBoundRange 20] prop_haddock_example :: Bool prop_haddock_example = shouldParse "-5,8-10,13-15,20-" [ UpperBoundRange (Bound 5 Inclusive) @@ -98,9 +96,9 @@ prop_parse_wildcard :: Bool prop_parse_wildcard = shouldParse "*" [InfiniteRange] +-- InfiniteRange absorbs everything; the canonical result is just inf. prop_parse_wildcard_in_union :: Bool -prop_parse_wildcard_in_union = shouldParse "*,5" - [InfiniteRange, SingletonRange 5] +prop_parse_wildcard_in_union = shouldParse "*,5" [InfiniteRange, SingletonRange 5] test_wildcard :: Test test_wildcard = testGroup "wildcard / infinite range" @@ -134,18 +132,18 @@ -- --------------------------------------------------------------------------- prop_empty_string_parses :: Bool -prop_empty_string_parses = case (parseRanges "" :: Either ParseError [Range Integer]) of - Right [] -> True - _ -> False +prop_empty_string_parses = case (parseRanges "" :: Either ParseError (Ranges Integer)) of + Right result -> result == mempty + _ -> False -- The parser uses sepBy which returns [] on no matches, --- so non-range input like "abc" or "-" parses as Right []. +-- so non-range input like "abc" parses as Right mempty. -- This is a known limitation of the current parser design. prop_non_range_input_parses_empty :: Bool prop_non_range_input_parses_empty = - case (parseRanges "abc" :: Either ParseError [Range Integer]) of - Right [] -> True - _ -> False + case (parseRanges "abc" :: Either ParseError (Ranges Integer)) of + Right result -> result == mempty + _ -> False test_edge_cases :: Test test_edge_cases = testGroup "edge cases" @@ -154,15 +152,53 @@ ] -- --------------------------------------------------------------------------- +-- Invalid inputs (must fail) +-- +-- The parser commits after consuming a union separator. If no valid range +-- follows the separator, it produces a Left rather than silently succeeding. +-- --------------------------------------------------------------------------- + +-- "1," — trailing comma: separator consumed, then end-of-input reached +-- before the next range element. +prop_trailing_comma_fails :: Bool +prop_trailing_comma_fails = shouldFail "1," + +-- "1,2,3," — trailing comma after multiple valid ranges. +prop_trailing_comma_after_many_fails :: Bool +prop_trailing_comma_after_many_fails = shouldFail "1,2,3," + +-- "1,,2" — double comma: separator consumed, then another comma is found +-- where a range element is expected. +prop_double_comma_fails :: Bool +prop_double_comma_fails = shouldFail "1,,2" + +-- "-" alone is the range separator with nothing on either side. +-- spanRange wraps in try so it backtracks; singletonRange needs digits. +-- The overall parser returns empty rather than failing (no input consumed). +-- This test documents that behaviour — it is NOT a failure case. +prop_bare_separator_parses_empty :: Bool +prop_bare_separator_parses_empty = + case (parseRanges "-" :: Either ParseError (Ranges Integer)) of + Right result -> result == mempty + _ -> False + +test_invalid :: Test +test_invalid = testGroup "invalid inputs" + [ testProperty "trailing comma produces parse error" prop_trailing_comma_fails + , testProperty "trailing comma after many ranges fails" prop_trailing_comma_after_many_fails + , testProperty "double comma produces parse error" prop_double_comma_fails + , testProperty "bare separator parses as empty (not an error)" prop_bare_separator_parses_empty + ] + +-- --------------------------------------------------------------------------- -- Custom parser args -- --------------------------------------------------------------------------- prop_custom_separators :: Bool prop_custom_separators = let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." } - result = customParseRanges args "1..5;10" :: Either ParseError [Range Integer] - in case result of - Right ranges -> ranges == + in case customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer) of + Right result -> result == mergeRanges [ SpanRange (Bound 1 Inclusive) (Bound 5 Inclusive) , SingletonRange 10 ] @@ -186,5 +222,6 @@ , test_wildcard , test_union , test_edge_cases + , test_invalid , test_custom ] diff --git a/range.cabal b/range.cabal --- a/range.cabal +++ b/range.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.0.0 +version: 1.0.0.0 -- A short (one-line) description of the package. synopsis: An efficient and versatile range library. @@ -95,7 +95,21 @@ , Test.RangeLaws , Test.RangeParser , Test.RangeOrd + , Test.RangeBounds , Test.Generators + -- library modules accessed directly by test internals: + , Data.Ranges + , Data.Range.Algebra + , Data.Range.Algebra.Internal + , Data.Range.Algebra.Predicate + , Data.Range.Algebra.Range + , Data.Range.Data + , Data.Range.Operators + , Data.Range.Ord + , Data.Range.Parser + , Data.Range.RangeInternal + , Data.Range.Spans + , Data.Range.Util build-depends: base >= 4.5 && < 5 , Cabal >= 1.14 , QuickCheck >= 2.4.0.1 && < 3 @@ -108,7 +122,7 @@ , containers >= 0.5 && < 1 , range default-language: Haskell2010 - ghc-options: -rtsopts -Wall -fno-enable-rewrite-rules + ghc-options: -rtsopts -Wall test-suite doctest-range type: exitcode-stdio-1.0