range 0.1.2.0 → 1.0.0.0
raw patch · 26 files changed
Files
- Bench/Range.hs +193/−0
- Data/Range.hs +11/−0
- Data/Range/Algebra.hs +80/−4
- Data/Range/Algebra/Internal.hs +42/−4
- Data/Range/Algebra/Predicate.hs +8/−4
- Data/Range/Algebra/Range.hs +2/−1
- Data/Range/Data.hs +53/−19
- Data/Range/NestedRange.hs +0/−29
- Data/Range/Operators.hs +56/−0
- Data/Range/Ord.hs +175/−0
- Data/Range/Parser.hs +93/−31
- Data/Range/Range.hs +0/−101
- Data/Range/RangeInternal.hs +143/−187
- Data/Range/RangeTree.hs +0/−29
- Data/Range/Spans.hs +27/−33
- Data/Range/Util.hs +159/−16
- Data/Ranges.hs +479/−0
- DocTest.hs +12/−0
- Test/Generators.hs +53/−0
- Test/Range.hs +21/−38
- Test/RangeBounds.hs +123/−0
- Test/RangeLaws.hs +170/−0
- Test/RangeMerge.hs +36/−20
- Test/RangeOrd.hs +250/−0
- Test/RangeParser.hs +227/−0
- range.cabal +75/−17
+ Bench/Range.hs view
@@ -0,0 +1,193 @@+module Main where++import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Test.Tasty.Bench++import Data.Ranges+import qualified Data.Range.Algebra as Alg++-- ---------------------------------------------------------------------------+-- Input generators+-- ---------------------------------------------------------------------------++-- | N disjoint spans: [0,1], [3,4], [6,7], ...+disjointSpans :: Int -> [Range Integer]+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 =+ [ SpanRange (Bound (fromIntegral i) Inclusive) (Bound (fromIntegral (i + 1000)) Inclusive)+ | i <- [0 .. n - 1]+ ]++-- | 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 (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 (Ranges Integer)+intersectionTree n = foldl1 Alg.intersection+ [ Alg.const (mergeRanges [ SpanRange (Bound (fromIntegral (i * 2)) Inclusive)+ (Bound (fromIntegral (i * 2 + 100)) Inclusive) ])+ | i <- [1 .. n :: Int]+ ]++-- ---------------------------------------------------------------------------+-- Main+-- ---------------------------------------------------------------------------++main :: IO ()+main = do+ -- Pre-evaluate all inputs so construction cost is excluded from benchmarks+ ds10 <- evaluate . force $ disjointSpans 10+ ds100 <- evaluate . force $ disjointSpans 100+ ds1000 <- evaluate . force $ disjointSpans 1000+ 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 (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 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 ms1000) 2998+ , bench "elem-1000" $ whnf (elem (2998 :: Integer)) el1000+ , bench "inRanges-10000" $ whnf (inRanges ms10000) 29998+ , bench "elem-10000" $ whnf (elem (29998 :: Integer)) el10000+ ]+ , bgroup "aboveRanges/disjoint-spans"+ [ 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 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 ds10+ , bench "100" $ nf mergeRanges ds100+ , bench "1000" $ nf mergeRanges ds1000+ ]+ , bgroup "mergeRanges/fully-overlapping"+ [ bench "10" $ nf mergeRanges os10+ , bench "100" $ nf mergeRanges os100+ , bench "1000" $ nf mergeRanges os1000+ ]+ , bgroup "mergeRanges/disjoint"+ [ bench "10" $ nf mergeRanges ds10+ , bench "100" $ nf mergeRanges ds100+ , bench "1000" $ nf mergeRanges ds1000+ ]+ , bgroup "union"+ [ bench "10" $ nf (union ms10) ms10+ , bench "100" $ nf (union ms100) ms100+ , bench "1000" $ nf (union ms1000) ms1000+ ]+ , bgroup "intersection/disjoint"+ -- 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 oms10) oms10+ , bench "100" $ nf (intersection oms100) oms100+ , bench "1000" $ nf (intersection oms1000) oms1000+ ]+ , bgroup "difference"+ [ bench "10" $ nf (difference ms10) ms10+ , bench "100" $ nf (difference ms100) ms100+ , bench "1000" $ nf (difference ms1000) ms1000+ ]+ , bgroup "invert"+ [ bench "10" $ nf invert ms10+ , bench "100" $ nf invert ms100+ , bench "1000" $ nf invert ms1000+ ]+ ]++ , bgroup "construction-conversion"+ [ bgroup "fromRanges/take-N"+ [ 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 ms10+ , bench "100" $ nf joinRanges ms100+ , bench "1000" $ nf joinRanges ms1000+ ]+ ]++ , bgroup "algebra"+ [ bgroup "eval/union-tree"+ [ bench "5" $ nf Alg.eval (unionTree 5)+ , bench "10" $ nf Alg.eval (unionTree 10)+ , bench "20" $ nf Alg.eval (unionTree 20)+ ]+ , bgroup "eval/intersection-tree"+ [ bench "5" $ nf Alg.eval (intersectionTree 5)+ , bench "10" $ nf Alg.eval (intersectionTree 10)+ , bench "20" $ nf Alg.eval (intersectionTree 20)+ ]+ ]+ ]
+ Data/Range.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE Safe #-}++-- | __Deprecated.__ Import "Data.Ranges" instead.+--+-- 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++import Data.Ranges
Data/Range/Algebra.hs view
@@ -1,11 +1,55 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +-- | Internally the range library converts your ranges into an internal+-- efficient representation. When you perform multiple unions and intersections+-- in a row, converting to and from that representation on every step is extra+-- work. The @RangeExpr@ algebra amortises this cost: build a tree of operations+-- first, then evaluate the whole tree in one pass.+--+-- __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 '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+-- <https://www.schoolofhaskell.com/user/bartosz/understanding-algebras this introduction>+-- from the School of Haskell.+--+-- == Examples+--+-- Evaluate to a 'Data.Ranges.Ranges' value (the typical use):+--+-- @+-- import qualified Data.Range.Algebra as A+-- 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 structure built):+--+-- @+-- 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- ( RangeExpr- -- ** Operations+ ( -- * Expression trees+ RangeExpr+ -- ** Building expressions , const, invert, union, intersection, difference- -- ** Evaluation+ -- * Evaluation , Algebra, RangeAlgebra(..) ) where @@ -18,26 +62,58 @@ import Control.Monad.Free +-- | Lifts a value as a constant leaf into an expression tree.+--+-- Note: this function shadows 'Prelude.const'. The "Data.Range.Algebra" module+-- uses @import Prelude hiding (const)@; callers that import both should qualify. const :: a -> RangeExpr a const = RangeExpr . Pure +-- | Wraps an expression in a set-complement (invert) node.+-- When evaluated, produces all values /not/ covered by the inner expression.+-- Note that @'invert' . 'invert' == 'id'@. invert :: RangeExpr a -> RangeExpr a invert = RangeExpr . Free . Invert . getFree +-- | Wraps two expressions in a set-union node.+-- When evaluated, produces all values covered by either expression. union :: RangeExpr a -> RangeExpr a -> RangeExpr a union a b = RangeExpr . Free $ Union (getFree a) (getFree b) +-- | Wraps two expressions in a set-intersection node.+-- When evaluated, produces only values covered by both expressions. intersection :: RangeExpr a -> RangeExpr a -> RangeExpr a intersection a b = RangeExpr . Free $ Intersection (getFree a) (getFree b) +-- | Wraps two expressions in a set-difference node.+-- When evaluated, produces values in the first expression that are absent from the second. difference :: RangeExpr a -> RangeExpr a -> RangeExpr a difference a b = RangeExpr . Free $ Difference (getFree a) (getFree b) +-- | A type class for types that a 'RangeExpr' can be evaluated to.+-- 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. Three evaluation targets are supported:+ --+ -- * '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 -instance (Ord a, Enum a) => RangeAlgebra [Range a] where+-- | Evaluates to a merged, canonical list of non-overlapping ranges.+-- 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'@.+-- 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
Data/Range/Algebra/Internal.hs view
@@ -6,24 +6,62 @@ import Prelude hiding (const) -import Data.Range.Data import Data.Range.RangeInternal import Control.Monad.Free+import Data.Functor.Classes data RangeExprF r = Invert r | Union r r | Intersection r r | Difference r r- deriving (Show, Eq, Ord, Functor)+ deriving (Show, Eq, Functor) +instance Eq1 RangeExprF where+ liftEq eq (Invert a) (Invert b) = eq a b+ liftEq eq (Union a c) (Union b d) = eq a b && eq c d+ liftEq eq (Intersection a c) (Intersection b d) = eq a b && eq c d+ liftEq eq (Difference a c) (Difference b d) = eq a b && eq c d+ liftEq _ _ _ = False++instance Show1 RangeExprF where+ liftShowsPrec showPrec _ p (Invert x) = showString "not " . showParen True (showPrec (p + 1) x)+ liftShowsPrec showPrec _ p (Union a b) =+ showPrec (p + 1) a .+ showString " \\/ " .+ showPrec (p + 1) b+ liftShowsPrec showPrec _ p (Intersection a b) =+ showPrec (p + 1) a .+ showString " /\\ " .+ showPrec (p + 1) b+ liftShowsPrec showPrec _ p (Difference a b) =+ showPrec (p + 1) a .+ showString " - " .+ showPrec (p + 1) b++-- | An expression tree representing a sequence of set operations on ranges.+-- Construct trees with 'Data.Range.Algebra.const', 'Data.Range.Algebra.union',+-- 'Data.Range.Algebra.intersection', 'Data.Range.Algebra.difference', and+-- 'Data.Range.Algebra.invert', then collapse the tree with 'Data.Range.Algebra.eval'.+--+-- The type parameter @a@ is the range representation the tree will eventually+-- evaluate to (e.g. @['Data.Range.Range' Integer]@ or @Integer -> 'Bool'@).+--+-- @RangeExpr@ is a 'Functor', so you can map over the leaf values before evaluation. newtype RangeExpr a = RangeExpr { getFree :: Free RangeExprF a }- deriving (Show, Eq, Ord, Functor)+ deriving (Show, Eq, Functor) +-- | The type of an evaluation function for a 'RangeExpr'. You will not normally+-- need to reference this alias directly; it exists to express the signature of+-- 'Data.Range.Algebra.eval'.+--+-- Concretely, @Algebra f a = f a -> a@, meaning: given a functor @f@ applied to+-- an already-evaluated @a@, produce the final @a@. The 'Control.Monad.Free.iter'+-- function from the @free@ package drives the bottom-up fold. type Algebra f a = f a -> a -rangeMergeAlgebra :: (Ord a, Enum a) => Algebra RangeExprF (RangeMerge a)+rangeMergeAlgebra :: (Ord a) => Algebra RangeExprF (RangeMerge a) rangeMergeAlgebra (Invert a) = invertRM a rangeMergeAlgebra (Union a b) = a `unionRangeMerges` b rangeMergeAlgebra (Intersection a b) = a `intersectionRangeMerges` b
Data/Range/Algebra/Predicate.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE Safe #-} module Data.Range.Algebra.Predicate where +import Control.Applicative+ import Data.Range.Algebra.Internal predicateAlgebra :: Algebra RangeExprF (a -> Bool)-predicateAlgebra (Invert f) a = not (f a)-predicateAlgebra (Union f g) a = f a || g a-predicateAlgebra (Intersection f g) a = f a && g a-predicateAlgebra (Difference f g) a = f a && not (g a)+predicateAlgebra (Invert f) = liftA not f+predicateAlgebra (Union f g) = liftA2 (||) f g+predicateAlgebra (Intersection f g) = liftA2 (&&) f g+predicateAlgebra (Difference f g) = liftA2 (&&~) f g+ where (&&~) a b = a && not b
Data/Range/Algebra/Range.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Safe #-} module Data.Range.Algebra.Range where import Data.Range.Data@@ -6,5 +7,5 @@ import Control.Monad.Free -rangeAlgebra :: (Ord a, Enum a) => Algebra RangeExprF [Range a]+rangeAlgebra :: (Ord a) => Algebra RangeExprF [Range a] rangeAlgebra = exportRangeMerge . iter rangeMergeAlgebra . Free . fmap (Pure . loadRanges)
Data/Range/Data.hs view
@@ -1,30 +1,64 @@ {-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-} -- | The Data module for common data types within the code. module Data.Range.Data where +import Control.DeepSeq (NFData)+import GHC.Generics (Generic)++data OverlapType = Separate | Overlap | Adjoin+ deriving (Eq, Show, Generic)++instance NFData OverlapType++-- | Represents a type of boundary.+data BoundType+ = Inclusive -- ^ The value at the boundary should be included in the bound.+ | Exclusive -- ^ The value at the boundary should be excluded in the bound.+ deriving (Eq, Ord, Show, Generic)++instance NFData BoundType++-- | Represents a bound at a particular value with a 'BoundType'.+-- There is no implicit understanding if this is a lower or upper bound, it could be either.+data Bound a = Bound+ { boundValue :: a -- ^ The value at the edge of this bound.+ , boundType :: BoundType -- ^ The type of bound. Should be 'Inclusive' or 'Exclusive'.+ } deriving (Eq, Ord, Show, Generic)++instance NFData a => NFData (Bound a)++instance Functor Bound where+ fmap f (Bound v vType) = Bound (f v) vType++-- TODO can we implement Monoid for Range a with the addition of an empty?+-- Or maybe we can implement Monoid for a list of ranges...+ -- | The Range Data structure; it is capable of representing any type of range. This is -- the primary data structure in this library. Everything should be possible to convert -- back into this datatype. All ranges in this structure are inclusively bound. data Range a- = SingletonRange a -- ^ Represents a single element as a range.- | SpanRange a a -- ^ Represents a bounded and inclusive range of elements.- | LowerBoundRange a -- ^ Represents a range with only an inclusive lower bound.- | UpperBoundRange a -- ^ Represents a range with only an inclusive upper bound.- | InfiniteRange -- ^ Represents an infinite range over all values.- deriving(Eq, Show)+ = SingletonRange a -- ^ Represents a single element as a range. @SingletonRange a@ is equivalent to @SpanRange (Bound a Inclusive) (Bound a Inclusive)@.+ | SpanRange (Bound a) (Bound a) -- ^ Represents a bounded span of elements. The first argument is expected to be less than or equal to the second argument.+ | LowerBoundRange (Bound a) -- ^ Represents a range with a finite lower bound and an infinite upper bound.+ | UpperBoundRange (Bound a) -- ^ Represents a range with an infinite lower bound and a finite upper bound.+ | InfiniteRange -- ^ Represents an infinite range over all values.+ deriving (Eq, Generic) --- | These are the operations that can join two disjunct lists of ranges together.-data RangeOperation- = RangeUnion -- ^ Represents the set union operation.- | RangeIntersection -- ^ Represents the set intersection operation.- | RangeDifference -- ^ Represents the set difference operation.+instance NFData a => NFData (Range a) --- | A Range Tree is a construct that can be built and then efficiently evaluated so that--- you can compress an entire tree of operations on ranges into a single range quickly.--- The only purpose of this tree is to allow efficient construction of range operations--- that can be evaluated as is required.-data RangeTree a- = RangeNode RangeOperation (RangeTree a) (RangeTree a) -- ^ Combine two range trees together with a single operation- | RangeNodeInvert (RangeTree a) -- ^ Invert a range tree, this is a 'not' operation.- | RangeLeaf [Range a] -- ^ A leaf with a set of ranges that are collected together.+instance Show a => Show (Range a) where+ showsPrec i (SingletonRange a) = ((++) "SingletonRange ") . showsPrec i a+ showsPrec i (SpanRange (Bound l lType) (Bound r rType)) =+ showsPrec i l . showSymbol lType rType . showsPrec i r+ where+ showSymbol Inclusive Inclusive = (++) " +=+ "+ showSymbol Inclusive Exclusive = (++) " +=* "+ showSymbol Exclusive Inclusive = (++) " *=+ "+ showSymbol Exclusive Exclusive = (++) " *=* "+ showsPrec i (LowerBoundRange (Bound a Inclusive)) = ((++) "lbi ") . (showsPrec i a)+ showsPrec i (LowerBoundRange (Bound a Exclusive)) = ((++) "lbe ") . (showsPrec i a)+ showsPrec i (UpperBoundRange (Bound a Inclusive)) = ((++) "ubi ") . (showsPrec i a)+ showsPrec i (UpperBoundRange (Bound a Exclusive)) = ((++) "ube ") . (showsPrec i a)+ showsPrec _ (InfiniteRange) = (++) "inf"
− Data/Range/NestedRange.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE Safe #-}---- | Nested Ranges are common in practical usage. They appear in such forms as library--- version numbers ("Version 1.4.5.6" for example). And it is very useful to be able to--- compare these ranges to one another. This module exists for the purpose of allowing--- these comparisons between nested ranges. The module builds upon the basic range concept--- from other parts of this library.-module Data.Range.NestedRange where--import Data.Range.Range---- | The Nested Range is a structure that in a nested form of many ranges where there can--- be multiple ranges at every level.-data NestedRange a = NestedRange [[Range a]]----- I wanted to know if a nested number of elements are in a given range. That way I can--- just immediately run a single function and tell things about ranges.---- | Given a list of nested values and a nested range tell us wether the nested value--- exists inside the nested range.-inNestedRange :: Ord a => [a] -> NestedRange a -> Bool-inNestedRange values (NestedRange ranges) = go values ranges- where- go :: Ord a => [a] -> [[Range a]] -> Bool- go [] [] = True -- If there is nothing left then they are equal- go _ [] = True -- If you have already found the values you have to be in range then they are- go [] _ = False -- If you have not fully matched it yet then it is not in range.- go (value : vs) (range : rs) = inRanges range value && go vs rs
+ Data/Range/Operators.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE Safe #-}+module Data.Range.Operators where++import Data.Range.Data++-- | Mathematically equivalent to @[x, y]@.+--+-- @x +=+ y@ is the short version of @SpanRange (Bound x Inclusive) (Bound y Inclusive)@+(+=+) :: a -> a -> Range a+(+=+) x y = SpanRange (Bound x Inclusive) (Bound y Inclusive)++-- | Mathematically equivalent to @[x, y)@.+--+-- @x +=* y@ is the short version of @SpanRange (Bound x Inclusive) (Bound y Exclusive)@+(+=*) :: a -> a -> Range a+(+=*) x y = SpanRange (Bound x Inclusive) (Bound y Exclusive)++-- | Mathematically equivalent to @(x, y]@.+--+-- @x *=+ y@ is the short version of @SpanRange (Bound x Exclusive) (Bound y Inclusive)@+(*=+) :: a -> a -> Range a+(*=+) x y = SpanRange (Bound x Exclusive) (Bound y Inclusive)++-- | Mathematically equivalent to @(x, y)@.+--+-- @x *=* y@ is the short version of @SpanRange (Bound x Exclusive) (Bound y Exclusive)@+(*=*) :: a -> a -> Range a+(*=*) x y = SpanRange (Bound x Exclusive) (Bound y Exclusive)++-- | Mathematically equivalent to @[x, Infinity)@.+--+-- @lbi x@ is the short version of @LowerBoundRange (Bound x Inclusive)@+lbi :: a -> Range a+lbi x = LowerBoundRange (Bound x Inclusive)++-- | Mathematically equivalent to @(x, Infinity)@.+--+-- @lbe x@ is the short version of @LowerBoundRange (Bound x Exclusive)@+lbe :: a -> Range a+lbe x = LowerBoundRange (Bound x Exclusive)++-- | Mathematically equivalent to @(Infinity, x]@.+--+-- @ubi x@ is the short version of @UpperBoundRange (Bound x Inclusive)@+ubi :: a -> Range a+ubi x = UpperBoundRange (Bound x Inclusive)++-- | Mathematically equivalent to @(Infinity, x)@.+--+-- @ube x@ is the short version of @UpperBoundRange (Bound x Exclusive)@+ube :: a -> Range a+ube x = UpperBoundRange (Bound x Exclusive)++-- | Shorthand for the `InfiniteRange`+inf :: Range a+inf = InfiniteRange
+ Data/Range/Ord.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE Safe #-}++-- | Ordering newtypes for 'Range'.+--+-- 'Range' deliberately has no 'Ord' instance because there is no single+-- natural ordering — the right choice depends on the use case. This module+-- provides two explicit wrappers:+--+-- * 'KeyRange' — a consistent structural ordering, suitable for use as a+-- 'Data.Map.Map' key or in a 'Data.Set.Set'.+--+-- * 'SortedRange' — a positional ordering by location on the number line,+-- suitable for sorting ranges for display.+--+-- == Example: Map keyed on ranges+--+-- @+-- import Data.Range (Range, (+=+), lbi)+-- import Data.Range.Ord (KeyRange(..))+-- import qualified Data.Map.Strict as Map+--+-- type RuleMap = Map (KeyRange Integer) String+--+-- rules :: RuleMap+-- rules = Map.fromList+-- [ (KeyRange (1 +=+ 10), \"low\")+-- , (KeyRange (11 +=+ 50), \"medium\")+-- , (KeyRange (lbi 51), \"high\")+-- ]+-- @+--+-- == Example: sorting ranges by position on the number line+--+-- @+-- import Data.List (sortOn)+-- import Data.Range (Range, (+=+), lbi, ube)+-- import Data.Range.Ord (SortedRange(..))+--+-- sortOn SortedRange [lbi 10, 1 +=+ 5, ube 0 :: Range Integer]+-- -- [ube 0, 1 +=+ 5, lbi 10]+--+-- -- or equivalently:+-- displayRanges :: Ord a => [Range a] -> [Range a]+-- displayRanges = sortOn SortedRange+-- @+module Data.Range.Ord+ ( -- * Structural ordering+ -- | Use 'KeyRange' when you need 'Range' values as 'Data.Map.Map' keys or+ -- in a 'Data.Set.Set'. The ordering is consistent but not semantically+ -- meaningful on the number line.+ KeyRange(..)+ -- * Positional ordering+ -- | Use 'SortedRange' when you want to sort ranges by where they sit on+ -- the number line (lower bound first, upper bound as tiebreaker).+ , SortedRange(..)+ ) where++-- $setup+-- >>> import Data.Range+-- >>> import Data.Range.Ord+-- >>> import Data.List (sortOn)++import Data.Range.Data+import Data.Range.Util (compareLower, compareHigher)++-- ---------------------------------------------------------------------------+-- KeyRange: structural ordering+-- ---------------------------------------------------------------------------++-- | Wraps 'Range' with a structural 'Ord' instance, suitable for use as a+-- 'Data.Map.Map' key or in a 'Data.Set.Set'.+--+-- Constructor order: @SingletonRange < SpanRange < LowerBoundRange <+-- UpperBoundRange < InfiniteRange@. Fields within the same constructor are+-- compared lexicographically.+--+-- This ordering is not semantically meaningful on the number line —+-- @SingletonRange 5@ and @SpanRange (Bound 5 Inclusive) (Bound 5 Inclusive)@+-- are considered distinct. It is only appropriate where any consistent total+-- order will do (deduplication, 'Data.Map.Map' keys).+--+-- Use 'unKeyRange' to unwrap the underlying 'Range'.+--+-- See also 'SortedRange' for ordering by position on the number line.+--+-- @since 0.3.2.0+newtype KeyRange a = KeyRange { unKeyRange :: Range a }+ deriving (Eq, Show)++constructorRank :: Range a -> Int+constructorRank (SingletonRange _) = 0+constructorRank (SpanRange _ _) = 1+constructorRank (LowerBoundRange _) = 2+constructorRank (UpperBoundRange _) = 3+constructorRank InfiniteRange = 4++compareRangeFields :: Ord a => Range a -> Range a -> Ordering+compareRangeFields (SingletonRange a) (SingletonRange b) = compare a b+compareRangeFields (SpanRange lo1 hi1) (SpanRange lo2 hi2) =+ case compare lo1 lo2 of+ EQ -> compare hi1 hi2+ r -> r+compareRangeFields (LowerBoundRange a) (LowerBoundRange b) = compare a b+compareRangeFields (UpperBoundRange a) (UpperBoundRange b) = compare a b+compareRangeFields InfiniteRange InfiniteRange = EQ+compareRangeFields _ _ = EQ++instance Ord a => Ord (KeyRange a) where+ compare (KeyRange x) (KeyRange y) =+ case compare (constructorRank x) (constructorRank y) of+ EQ -> compareRangeFields x y+ r -> r++-- ---------------------------------------------------------------------------+-- SortedRange: positional ordering+-- ---------------------------------------------------------------------------++-- | Extended bound adding @-∞@ and @+∞@ sentinels, used internally by+-- 'SortedRange'.+data ExtBound a = NegInfinity | FiniteBound (Bound a) | PosInfinity++compareExtBound :: (Bound a -> Bound a -> Ordering) -> ExtBound a -> ExtBound a -> Ordering+compareExtBound _ NegInfinity NegInfinity = EQ+compareExtBound _ NegInfinity _ = LT+compareExtBound _ _ NegInfinity = GT+compareExtBound _ PosInfinity PosInfinity = EQ+compareExtBound _ PosInfinity _ = GT+compareExtBound _ _ PosInfinity = LT+compareExtBound cmp (FiniteBound a) (FiniteBound b) = cmp a b++lowerExtBound :: Range a -> ExtBound a+lowerExtBound (UpperBoundRange _) = NegInfinity+lowerExtBound InfiniteRange = NegInfinity+lowerExtBound (LowerBoundRange b) = FiniteBound b+lowerExtBound (SpanRange lo _) = FiniteBound lo+lowerExtBound (SingletonRange x) = FiniteBound (Bound x Inclusive)++upperExtBound :: Range a -> ExtBound a+upperExtBound (LowerBoundRange _) = PosInfinity+upperExtBound InfiniteRange = PosInfinity+upperExtBound (UpperBoundRange b) = FiniteBound b+upperExtBound (SpanRange _ hi) = FiniteBound hi+upperExtBound (SingletonRange x) = FiniteBound (Bound x Inclusive)++-- | Wraps 'Range' with a positional 'Ord' instance: ranges are ordered by+-- where they sit on the number line, lower bound first with upper bound as a+-- tiebreaker.+--+-- The 'Eq' instance is consistent with 'Ord': two 'SortedRange' values are+-- equal iff they have the same lower and upper bounds. This means+-- @SortedRange (SingletonRange 5)@ and @SortedRange (5 +=+ 5)@ are considered+-- equal (they occupy the same point on the number line).+--+-- Use 'unSortedRange' to unwrap the underlying 'Range'. Typical usage:+--+-- >>> import Data.List (sortOn)+-- >>> sortOn SortedRange [SingletonRange 5, SingletonRange 1, SingletonRange 3 :: Range Integer]+-- [SingletonRange 1,SingletonRange 3,SingletonRange 5]+--+-- See also 'KeyRange' for a structural ordering suitable for 'Data.Map.Map' keys.+--+-- @since 0.3.2.0+newtype SortedRange a = SortedRange { unSortedRange :: Range a }++instance Show a => Show (SortedRange a) where+ show (SortedRange r) = "SortedRange (" ++ show r ++ ")"++instance Ord a => Eq (SortedRange a) where+ x == y = compare x y == EQ++instance Ord a => Ord (SortedRange a) where+ compare (SortedRange a) (SortedRange b) =+ case compareExtBound compareLower (lowerExtBound a) (lowerExtBound b) of+ EQ -> compareExtBound compareHigher (upperExtBound a) (upperExtBound b)+ r -> r
Data/Range/Parser.hs view
@@ -1,57 +1,119 @@ {-# LANGUAGE FlexibleContexts #-} --- | It should not be unexpected that you will be given a string representation of some--- ranges and you will need to parse them so that you can then do some further processing.--- This parser exists in order to make the most common forms of range strings easy to--- parse. It does not cover all cases however but you should not be too worried about--- that because you should be able to write your own parser using parsec or Alex/Happy and--- then you can convert everything that you parse into a RangeTree object for easier--- processing.-module Data.Range.Parser - ( parseRanges- , ranges+-- | A simple parser for human-readable range strings, designed for CLI programs.+--+-- By default, ranges are separated by commas and span endpoints by a hyphen:+--+-- >>> 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 (Ranges Integer)+-- Right (Ranges [inf])+--+-- Use 'customParseRanges' to change the separator characters:+--+-- >>> let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." }+-- >>> customParseRanges args "1..5;10" :: Either ParseError (Ranges Integer)+-- Right (Ranges [1 +=+ 5,SingletonRange 10])+--+-- __Known limitations:__+--+-- * Only non-negative integer literals are recognised. The input @\"-5\"@ is parsed+-- as @UpperBoundRange 5@ (an upper-bounded range), not @SingletonRange (-5)@.+-- For negative values, use 'customParseRanges' with a different 'rangeSeparator',+-- or pre-process the input string.+--+-- * 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,+-- then call 'mergeRanges'.+module Data.Range.Parser+ ( -- * Parsing+ parseRanges+ , customParseRanges+ -- * Configuration , RangeParserArgs(..) , defaultArgs+ -- * Lower-level parser+ , ranges+ -- * Re-exports+ -- | 'ParseError' is re-exported from "Text.Parsec" for convenience, so+ -- callers do not need to import Parsec directly just to match on parse failures.+ , ParseError ) where +-- $setup+-- >>> import Data.Ranges+-- >>> import Data.Range.Parser+ import Text.Parsec import Text.Parsec.String -import Data.Range.Range+import Data.Ranges --- | The arguments that are used, and can be modified, while parsing a standard range--- string.-data RangeParserArgs = Args - { unionSeparator :: String -- ^ A separator that represents a union.- , rangeSeparator :: String -- ^ A separator that separates the two halves of a range.- , wildcardSymbol :: String -- ^ A separator that implies an unbounded range.+-- | Configuration for the range parser. All three fields are plain strings, so+-- multi-character separators (e.g. @\"..\"@) are supported.+data RangeParserArgs = Args+ { unionSeparator :: String -- ^ Separates multiple ranges in a union. Default: @\",\"@.+ , rangeSeparator :: String -- ^ Separates the two endpoints of a span. Default: @\"-\"@.+ , wildcardSymbol :: String -- ^ Symbol for an infinite range. Default: @\"*\"@. } deriving(Show) --- | These are the default arguments that are used by the parser. Please feel free to use--- the default arguments for you own parser and modify it from the defaults at will.-defaultArgs :: RangeParserArgs +-- | The default parser configuration: comma-separated ranges, hyphen-separated+-- endpoints, and @*@ as the wildcard. Modify individual fields with record syntax:+--+-- >>> defaultArgs { unionSeparator = ";", rangeSeparator = ".." }+-- Args {unionSeparator = ";", rangeSeparator = "..", wildcardSymbol = "*"}+defaultArgs :: RangeParserArgs defaultArgs = Args { unionSeparator = "," , rangeSeparator = "-" , wildcardSymbol = "*" } --- | Given a string this function will either return a parse error back to the user or the--- list of ranges that are represented by the parsed string.-parseRanges :: (Read a) => String -> Either ParseError [Range a]-parseRanges = parse (ranges defaultArgs) "(range parser)"+-- | Parses a range string using the default separators (@,@ and @-@). Returns+-- 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'+-- instances may not parse correctly.+--+-- See the module documentation for known limitations around negative numbers+-- and unrecognised input.+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 (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 () --- | Given the parser arguments this returns a parser that is capable of parsing a list of--- ranges.+-- | 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 + where range :: (Read a) => Parser (Range a)- range = choice + range = choice [ infiniteRange , spanRange , singletonRange@@ -68,9 +130,9 @@ string_ $ rangeSeparator args second <- readSection case (first, second) of- (Just x, Just y) -> return $ SpanRange x y- (Just x, _) -> return $ LowerBoundRange x- (_, Just y) -> return $ UpperBoundRange y+ (Just x, Just y) -> return $ SpanRange (Bound x Inclusive) (Bound y Inclusive)+ (Just x, _) -> return $ LowerBoundRange (Bound x Inclusive)+ (_, Just y) -> return $ UpperBoundRange (Bound y Inclusive) _ -> parserFail ("Range should have a number on one end: " ++ rangeSeparator args) singletonRange :: (Read a) => Parser (Range a)
− Data/Range/Range.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE Safe #-}---- | This entire library is concerned with ranges and this module implements the absolute--- basic range functions.-module Data.Range.Range (- Range(..),- inRange,- inRanges,- rangesOverlap,- mergeRanges,- invert,- union,- intersection,- difference,- fromRanges- ) where--import Data.Range.Data-import Data.Range.Util-import qualified Data.Range.Algebra as Alg---- | Performs a set union between the two input ranges and returns the resultant set of--- ranges.-union :: (Ord a, Enum 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.-intersection :: (Ord a, Enum 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.-difference :: (Ord a, Enum a) => [Range a] -> [Range a] -> [Range a]-difference a b = Alg.eval $ Alg.difference (Alg.const a) (Alg.const b)-{-# INLINE difference #-}---- | An inversion function, given a set of ranges it returns the inverse set of ranges.-invert :: (Ord a, Enum a) => [Range a] -> [Range a]-invert = Alg.eval . Alg.invert . Alg.const-{-# INLINE invert #-}---- | A check to see if two ranges overlap. If they do then true is returned; false--- otherwise.-rangesOverlap :: (Ord a) => Range a -> Range a -> Bool-rangesOverlap (SingletonRange a) (SingletonRange b) = a == b-rangesOverlap (SingletonRange a) (SpanRange x y) = isBetween a (x, y)-rangesOverlap (SingletonRange a) (LowerBoundRange lower) = lower <= a-rangesOverlap (SingletonRange a) (UpperBoundRange upper) = a <= upper-rangesOverlap (SpanRange x y) (SpanRange a b) = isBetween x (a, b) || isBetween a (x, y)-rangesOverlap (SpanRange _ y) (LowerBoundRange lower) = lower <= y-rangesOverlap (SpanRange x _) (UpperBoundRange upper) = x <= upper-rangesOverlap (LowerBoundRange _) (LowerBoundRange _) = True-rangesOverlap (LowerBoundRange x) (UpperBoundRange y) = x <= y-rangesOverlap (UpperBoundRange _) (UpperBoundRange _) = True-rangesOverlap InfiniteRange _ = True-rangesOverlap a b = rangesOverlap b a---- | Given a range and a value it will tell you wether or not the value is in the range.--- Remember that all ranges are inclusive.-inRange :: (Ord a) => Range a -> a -> Bool-inRange (SingletonRange a) value = value == a-inRange (SpanRange x y) value = isBetween value (x, y)-inRange (LowerBoundRange lower) value = lower <= value-inRange (UpperBoundRange upper) value = value <= upper-inRange InfiniteRange _ = True---- | Given a list of ranges this function tells you if a value is in any of those ranges.--- This is especially useful for more complex ranges.-inRanges :: (Ord a) => [Range a] -> a -> Bool-inRanges rs a = any (`inRange` a) rs---- | When you create a range there may be overlaps in your ranges. However, for the sake--- of efficiency you probably want the list of ranges with no overlaps. The mergeRanges--- function takes a set of ranges and returns the same set specified by the minimum number--- of Range objects. A useful function for cleaning up your ranges. Please note that, if--- you use any of the other operations on sets of ranges like invert, union and--- intersection then this is automatically done for you. Which means that a function like--- this is redundant: mergeRanges . intersection-mergeRanges :: (Ord a, Enum a) => [Range a] -> [Range a]-mergeRanges = Alg.eval . Alg.const-{-# INLINE mergeRanges #-}---- | A set of ranges represents a collection of real values without actually instantiating--- those values. This allows you to have infinite ranges. However, sometimes you wish to--- actually 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.-fromRanges :: (Ord a, Enum a) => [Range a] -> [a]-fromRanges = concatMap fromRange- where- fromRange range = case range of- SingletonRange x -> [x]- SpanRange a b -> [a..b]- LowerBoundRange x -> iterate succ x- UpperBoundRange x -> iterate pred x- InfiniteRange -> zero : takeEvenly (tail $ iterate succ zero) (tail $ iterate pred zero)- where- zero = toEnum 0
Data/Range/RangeInternal.hs view
@@ -1,27 +1,30 @@ {-# LANGUAGE Safe #-}+{-# LANGUAGE BangPatterns #-} module Data.Range.RangeInternal where import Data.Maybe (catMaybes)---import Data.Ord (comparing)+import qualified Data.Map.Strict as Map import Data.Range.Data import Data.Range.Spans import Data.Range.Util +import Control.Monad (guard)+ {- - The following assumptions must be maintained at the beginning of these internal - functions so that we can reason about what we are given. - - RangeMerge assumptions:- - * The span ranges will never overlap the bounds. + - * The span ranges will never overlap the bounds. - * The span ranges are always sorted in ascending order by the first element. - * The lower and upper bounds never overlap in such a way to make it an infinite range. -} data RangeMerge a = RM- { largestLowerBound :: Maybe a- , largestUpperBound :: Maybe a- , spanRanges :: [(a, a)]+ { largestLowerBound :: Maybe (Bound a)+ , largestUpperBound :: Maybe (Bound a)+ , spanRanges :: [(Bound a, Bound a)] } | IRM deriving (Show, Eq)@@ -31,71 +34,76 @@ 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 (SpanRange x y) = emptyRangeMerge { spanRanges = [(min x y, max x y)] }-storeRange (SingletonRange x) = emptyRangeMerge { spanRanges = [(x, x)] }+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 =+ 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, Enum a) => RangeMerge a -> [Range a] -> RangeMerge a+storeRanges :: (Ord a) => RangeMerge a -> [Range a] -> RangeMerge a storeRanges start ranges = foldr unionRangeMerges start (map storeRange ranges) -loadRanges :: (Ord a, Enum a) => [Range a] -> RangeMerge a+loadRanges :: (Ord a) => [Range a] -> RangeMerge a loadRanges = storeRanges emptyRangeMerge {-# INLINE[0] loadRanges #-} -exportRangeMerge :: (Ord a, Enum a) => RangeMerge a -> [Range a]+exportRangeMerge :: (Eq a) => RangeMerge a -> [Range a] exportRangeMerge IRM = [InfiniteRange]-exportRangeMerge rm = putAll rm+exportRangeMerge (RM lb up spans) = putUpperBound up ++ putSpans spans ++ putLowerBound lb where- putAll IRM = [InfiniteRange]- putAll (RM lb up spans) = - putLowerBound lb ++ putUpperBound up ++ putSpans spans-+ putLowerBound :: Maybe (Bound a) -> [Range a] putLowerBound = maybe [] (return . LowerBoundRange)+ putUpperBound :: Maybe (Bound a) -> [Range a] putUpperBound = maybe [] (return . UpperBoundRange) putSpans = map simplifySpan - simplifySpan (x, y) = if x == y- then SingletonRange x+ simplifySpan (x@(Bound xv xType), y@(Bound _ yType)) = if (x == y) && (pointJoinType xType yType /= Separate)+ 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 where- newSpans = intersectSpans (spanRanges one) (spanRanges two) + newSpans = intersectSpans (spanRanges one) (spanRanges two) -intersectWith :: (Ord a) => (a -> (a, a) -> Maybe (a, a)) -> Maybe a -> [(a, a)] -> [(a, a)]+intersectWith :: (Ord a) => (Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)) -> Maybe (Bound a) -> [(Bound a, Bound a)] -> [(Bound a, Bound a)] intersectWith _ Nothing _ = [] intersectWith fix (Just lower) xs = catMaybes $ fmap (fix lower) xs -fixLower :: (Ord a) => a -> (a, a) -> Maybe (a, a)-fixLower lower (x, y) = if lower <= y- then Just (max lower x, y)- else Nothing+fixLower :: (Ord a) => Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)+fixLower lower@(Bound lowerValue _) (x, y@(Bound yValue _)) = do+ guard (lowerValue <= yValue)+ return (maxBoundsIntersection lower x, y) -fixUpper :: (Ord a) => a -> (a, a) -> Maybe (a, a)-fixUpper upper (x, y) = if x <= upper- then Just (x, min y upper)- else Nothing+fixUpper :: (Ord a) => Bound a -> (Bound a, Bound a) -> Maybe (Bound a, Bound a)+fixUpper upper@(Bound upperValue _) (x@(Bound xValue _), y) = do+ guard (xValue <= upperValue)+ return (x, minBoundsIntersection y upper) -intersectionRangeMerges :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> RangeMerge a+intersectionRangeMerges :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a intersectionRangeMerges IRM two = two intersectionRangeMerges one IRM = one intersectionRangeMerges one two = RM { largestLowerBound = newLowerBound , largestUpperBound = newUpperBound- , spanRanges = joinedSpans+ , spanRanges = unionSpans sortedResults }- where + where lowerOneSpans = intersectWith fixLower (largestLowerBound one) (spanRanges two) lowerTwoSpans = intersectWith fixLower (largestLowerBound two) (spanRanges one) upperOneSpans = intersectWith fixUpper (largestUpperBound one) (spanRanges two) upperTwoSpans = intersectWith fixUpper (largestUpperBound two) (spanRanges one)- intersectedSpans = intersectSpans (spanRanges one) (spanRanges two) + intersectedSpans = intersectSpans (spanRanges one) (spanRanges two) - sortedResults = foldr1 insertionSortSpans + sortedResults = removeEmptySpans $ foldr1 insertionSortSpans [ lowerOneSpans , lowerTwoSpans , upperOneSpans@@ -104,56 +112,55 @@ , calculateBoundOverlap one two ] - joinedSpans = joinSpans . unionSpans $ sortedResults-- newLowerBound = calculateNewBound largestLowerBound max one two- newUpperBound = calculateNewBound largestUpperBound min one two+ newLowerBound = calculateNewBound largestLowerBound maxBoundsIntersection one two+ newUpperBound = calculateNewBound largestUpperBound minBoundsIntersection one two - calculateNewBound - :: (Ord a) - => (RangeMerge a -> Maybe a) - -> (a -> a -> a) - -> RangeMerge a -> RangeMerge a -> Maybe a- calculateNewBound ext comp one two = case (ext one, ext two) of+ calculateNewBound+ :: (Ord a)+ => (RangeMerge a -> Maybe (Bound a))+ -> (Bound a -> Bound a -> Bound a)+ -> RangeMerge a -> RangeMerge a -> Maybe (Bound a)+ calculateNewBound ext comp one' two' = case (ext one', ext two') of (Just x, Just y) -> Just $ comp x y (_, Nothing) -> Nothing (Nothing, _) -> Nothing -calculateBoundOverlap :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> [(a, a)]+calculateBoundOverlap :: (Ord a) => RangeMerge a -> RangeMerge a -> [(Bound a, Bound a)] calculateBoundOverlap one two = catMaybes [oneWay, secondWay] where- oneWay = case (largestLowerBound one, largestUpperBound two) of- (Just x, Just y) -> if y >= x - then Just (x, y)- else Nothing- _ -> Nothing+ oneWay = do+ x <- largestLowerBound one+ y <- largestUpperBound two+ guard (compareLower y x /= LT)+ return (x, y) - secondWay = case (largestLowerBound two, largestUpperBound one) of- (Just x, Just y) -> if y >= x - then Just (x, y)- else Nothing- _ -> Nothing- -unionRangeMerges :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a -> RangeMerge a+ secondWay = do+ x <- largestLowerBound two+ y <- largestUpperBound one+ guard (compareLower y x /= LT)+ return (x, y)++unionRangeMerges :: (Ord a) => RangeMerge a -> RangeMerge a -> RangeMerge a unionRangeMerges IRM _ = IRM unionRangeMerges _ IRM = IRM unionRangeMerges one two = infiniteCheck filterTwo where- filterOne = foldr filterLowerBound boundedRM joinedSpans- filterTwo = foldr filterUpperBound (filterOne { spanRanges = [] }) (spanRanges filterOne)- - infiniteCheck :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a+ filterOne = foldr filterLowerBound boundedRM (unionSpans sortedSpans)+ filterTwo = case filterOne of+ IRM -> IRM+ rm -> foldr filterUpperBound (rm { spanRanges = [] }) (spanRanges rm)++ infiniteCheck :: (Ord a) => RangeMerge a -> RangeMerge a infiniteCheck IRM = IRM- infiniteCheck rm@(RM (Just x) (Just y) _) = if x <= succ y + infiniteCheck rm@(RM (Just lower) (Just upper) _) = if compareUpperToLower upper lower /= LT then IRM else rm infiniteCheck rm = rm - newLowerBound = calculateNewBound largestLowerBound min one two- newUpperBound = calculateNewBound largestUpperBound max one two+ newLowerBound = calculateNewBound largestLowerBound minBounds one two+ newUpperBound = calculateNewBound largestUpperBound maxBounds one two sortedSpans = insertionSortSpans (spanRanges one) (spanRanges two)- joinedSpans = joinSpans . unionSpans $ sortedSpans boundedRM = RM { largestLowerBound = newLowerBound@@ -161,164 +168,113 @@ , spanRanges = [] } - calculateNewBound - :: (Ord a) - => (RangeMerge a -> Maybe a) - -> (a -> a -> a) - -> RangeMerge a -> RangeMerge a -> Maybe a- calculateNewBound ext comp one two = case (ext one, ext two) of+ calculateNewBound+ :: (Ord a)+ => (RangeMerge a -> Maybe (Bound a))+ -> (Bound a -> Bound a -> Bound a)+ -> RangeMerge a -> RangeMerge a -> Maybe (Bound a)+ calculateNewBound ext comp one' two' = case (ext one', ext two') of (Just x, Just y) -> Just $ comp x y (z, Nothing) -> z (Nothing, z) -> z -filterLowerBound :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a+filterLowerBound :: (Ord a) => (Bound a, Bound a) -> RangeMerge a -> RangeMerge a filterLowerBound _ IRM = IRM filterLowerBound a rm@(RM Nothing _ _) = rm { spanRanges = a : spanRanges rm }-filterLowerBound s@(lower, _) rm@(RM (Just lowestBound) _ _) = +filterLowerBound s@(lower, _) rm@(RM (Just lowestBound) _ _) = case boundCmp lowestBound s of GT -> rm { spanRanges = s : spanRanges rm } LT -> rm- EQ -> rm { largestLowerBound = Just $ min lowestBound lower }+ EQ -> rm { largestLowerBound = Just $ minBounds lowestBound lower } -filterUpperBound :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a+filterUpperBound :: (Ord a) => (Bound a, Bound a) -> RangeMerge a -> RangeMerge a filterUpperBound _ IRM = IRM filterUpperBound a rm@(RM _ Nothing _) = rm { spanRanges = a : spanRanges rm } filterUpperBound s@(_, upper) rm@(RM _ (Just upperBound) _) = case boundCmp upperBound s of LT -> rm { spanRanges = s : spanRanges rm } GT -> rm- EQ -> rm { largestUpperBound = Just $ max upperBound upper }--boundCmp :: (Ord a, Enum a) => a -> (a, a) -> Ordering-boundCmp x (a, b) = if isBetween x (pred a, succ b)- then EQ- else if x < pred a then LT else GT--appendSpanRM :: (Ord a, Enum a) => (a, a) -> RangeMerge a -> RangeMerge a-appendSpanRM _ IRM = IRM-appendSpanRM sp@(lower, higher) rm = - if (newUpper, newLower) == (lub, llb) && isLower lower newLower && (Just higher) > newUpper- then newRangesRM- { spanRanges = sp : spanRanges rm- }- else newRangesRM- { spanRanges = spanRanges rm- }- where- newRangesRM = rm - { largestLowerBound = newLower- , largestUpperBound = newUpper- }-- isLower :: Ord a => a -> Maybe a -> Bool- isLower _ Nothing = True- isLower y (Just x) = y < x-- lub = largestUpperBound rm- llb = largestLowerBound rm-- newLower = do- bound <- llb- return $ if bound <= higher- then min bound lower- else bound-- newUpper = do- bound <- lub- return $ if lower <= bound- then max bound higher- else bound+ EQ -> rm { largestUpperBound = Just $ maxBounds upperBound upper } -invertRM :: (Ord a, Enum a) => RangeMerge a -> RangeMerge a+invertRM :: (Ord a) => RangeMerge a -> RangeMerge a invertRM IRM = emptyRangeMerge invertRM (RM Nothing Nothing []) = IRM-invertRM (RM (Just lower) Nothing []) = RM Nothing (Just . pred $ lower) []-invertRM (RM Nothing (Just upper) []) = RM (Just . succ $ upper) Nothing []-invertRM (RM (Just lower) (Just upper) []) = RM Nothing Nothing [(succ upper, pred lower)]-invertRM rm = RM+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 lb ub spans@(firstSpan : _)) = RM { largestUpperBound = newUpperBound , largestLowerBound = newLowerBound , spanRanges = upperSpan ++ betweenSpans ++ lowerSpan } where- newLowerValue = succ . snd . last . spanRanges $ rm- newUpperValue = pred . 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 -> [(succ upper, newUpperValue)]- lowerSpan = case largestLowerBound rm of+ Just upper -> [(invertBound upper, newUpperValue)]+ lowerSpan = case lb of Nothing -> []- Just lower -> [(newLowerValue, pred lower)] + Just lower -> [(newLowerValue, invertBound lower)] - betweenSpans = invertSpans . spanRanges $ rm+ betweenSpans = invertSpans spans -{--unionRange :: (Ord a) => Range a -> RangeMerge a -> RangeMerge a-unionRange InfiniteRange rm = IRM-unionRange (LowerBoundRange lower) rm = case largestLowerBound rm of- Just currentLowest -> rm { largestLowerBound = Just $ min lower currentLowest }- Nothing -> rm { largestLowerBound = Just lower }--}+joinRM :: (Eq a, Enum a) => RangeMerge a -> RangeMerge a+joinRM o@(RM _ _ []) = o+joinRM rm = RM lower higher spansAfterHigher+ where+ joinedSpans = joinSpans . spanRanges $ rm -{--intersectSpansRM :: (Ord a) => RangeMerge a -> (a, a) -> [(a, a)]-intersectSpansRM rm sp@(lower, upper) = intersectedSpans- where - spans = spanRanges rm- intersectedSpans = catMaybes $ map (intersectCompareSpan sp) spans+ (lower, spansAfterLower) =+ case (largestLowerBound rm, reverse joinedSpans) of+ o@(Just l, ((xl, xh) : xs)) ->+ if (succ . highestValueInUpperBound $ xh) == lowestValueInLowerBound l+ then (Just xl, reverse xs)+ else o+ x -> x - largestSpan :: Ord a => [(a, a)] -> [(a, a)]- largestSpan [] = []- largestSpan xs = (foldr1 (\(l, m) (x, y) -> (min l x, max m y)) xs) : []+ (higher, spansAfterHigher) =+ case (largestUpperBound rm, spansAfterLower) of+ o@(Just h, ((xl, xh) : xs)) ->+ if highestValueInUpperBound h == (pred . lowestValueInLowerBound $ xl)+ then (Just xh, xs)+ else o+ x -> x -intersectCompareSpan :: Ord a => (a, a) -> (a, a) -> Maybe (a, a)-intersectCompareSpan f@(l, m) s@(x, y) = if isBetween l s || isBetween m s- then Just (max l x, min m y)- else Nothing--}+updateBound :: Bound a -> a -> Bound a+updateBound (Bound _ aType) b = Bound b aType --- If it was an infinite range then it should not be after an intersection unless it was--- an intersection with another infinite range.-{--intersectionRange :: (Ord a, Enum a) => Range a -> RangeMerge a -> RangeMerge a-intersectionRange InfiniteRange rm = rm -- Intersection with universe remains same-intersectionRange (LowerBoundRange lower) rm = rm- { largestLowerBound = largestLowerBound rm >>= return . max lower- , spanRanges = catMaybes . map (updateRange lower) . spanRanges $ rm- }- where- updateRange :: (Ord a) => a -> (a, a) -> Maybe (a, a)- updateRange lower (begin, end) = if lower <= end- then Just (max lower begin, end)- else Nothing-intersectionRange (UpperBoundRange upper) rm = rm- { largestUpperBound = largestUpperBound rm >>= return . min upper- , spanRanges = catMaybes . map (updateRange upper) . spanRanges $ rm- }- where- updateRange :: (Ord a) => a -> (a, a) -> Maybe (a, a)- updateRange upper (begin, end) = if begin <= upper- then Just (begin, min upper end)- else Nothing-intersectionRange (SpanRange lower upper) rm = rm- -- update the bounds first and then update the spans, if the spans were sorted then- { largestUpperBound = largestUpperBound rm >>= return . min upper- , largestLowerBound = largestLowerBound rm >>= return . max lower- -- they would be faster to update I suspect, lets start with not sorted- , spanRanges = joinUnionSortSpans . ((lower, upper) :) . spanRanges $ rm- }- where- joinUnionSortSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)]- joinUnionSortSpans = joinSpans . unionSpans . sortSpans+unmergeRM :: RangeMerge a -> [RangeMerge a]+unmergeRM IRM = [IRM]+unmergeRM (RM lower upper spans) =+ (maybe [] (\x -> [RM Nothing (Just x) []]) upper) +++ fmap (\x -> RM Nothing Nothing [x]) spans +++ (maybe [] (\x -> [RM (Just x) Nothing []]) lower) -intersectionRange (SingletonRange value) rm = intersectionRange (SpanRange value value) rm--}+-- | Pre-build a 'Data.Map'-backed lookup structure from a canonical span list,+-- returning an O(log n) membership predicate. Build the map once; apply the+-- returned function for every subsequent query.+-- Precondition: spans are sorted and non-overlapping (canonical form).+buildSpanQuery :: Ord a+ => Maybe (Bound a) -- ^ largest lower bound (semi-infinite tail)+ -> Maybe (Bound a) -- ^ largest upper bound (semi-infinite tail)+ -> [(Bound a, Bound a)] -- ^ canonical finite spans+ -> (a -> Bool)+buildSpanQuery lb ub spans =+ let !m = Map.fromList spans+ in \val ->+ let v = Bound val Inclusive+ in maybe False (\b -> Overlap == againstUpperBound v b) ub+ || maybe False (\b -> Overlap == againstLowerBound v b) lb+ || case Map.lookupLE v m of+ Nothing -> False+ Just (lo, hi) -> Overlap == boundIsBetween v (lo, hi)
− Data/Range/RangeTree.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE Safe #-}---- | Internally the range library converts your ranges into an internal representation of--- multiple ranges that I call a RangeMerge. When you do multiple unions and intersections--- in a row converting to and from that data structure becomes extra work that is not--- required. To amortize those costs away the RangeTree structure exists. You can specify--- a tree of operations in advance and then evaluate them all at once. This is not only--- useful for efficiency but for parsing too. Use RangeTree's whenever you wish to perform--- multiple operations in a row and wish for it to be as efficient as possible.-module Data.Range.RangeTree- ( evaluate- , RangeTree(..)- , RangeOperation(..)- ) where--import Data.Range.Data-import qualified Data.Range.Algebra as Alg--toExpr :: RangeTree a -> Alg.RangeExpr [Range a]-toExpr (RangeLeaf a) = Alg.const a-toExpr (RangeNodeInvert a) = Alg.invert (toExpr a)-toExpr (RangeNode RangeUnion a b) = Alg.union (toExpr a) (toExpr b)-toExpr (RangeNode RangeIntersection a b) = Alg.intersection (toExpr a) (toExpr b)-toExpr (RangeNode RangeDifference a b) = Alg.difference (toExpr a) (toExpr b)---- | Evaluates a Range Tree into the final set of ranges that it compresses down to. Use--- this whenever you want to finally evaluate your constructed Range Tree.-evaluate :: (Ord a, Enum a) => RangeTree a -> [Range a]-evaluate = Alg.eval . toExpr
Data/Range/Spans.hs view
@@ -3,57 +3,51 @@ -- This module contains every function that purely performs operations on spans. module Data.Range.Spans where -import Data.List (sortBy, insertBy)-import Data.Ord (comparing)- import Data.Range.Util- +import Data.Range.Data+ -- Assume that both inputs are sorted spans-insertionSortSpans :: (Ord a) => [(a, a)] -> [(a, a)] -> [(a, a)]-insertionSortSpans = insertionSort (comparing fst)+insertionSortSpans :: (Ord a) => [(Bound a, Bound a)] -> [(Bound a, Bound a)] -> [(Bound a, Bound a)]+insertionSortSpans = insertionSort (\a b -> compareLower (fst a) (fst b)) -spanCmp :: Ord a => (a, a) -> (a, a) -> Ordering-spanCmp x@(xlow, xhigh) y@(ylow, _) = if isBetween xlow y || isBetween ylow x- then EQ- else if xhigh < ylow then LT else GT+spanCmp :: Ord a => (Bound a, Bound a) -> (Bound a, Bound a) -> Ordering+spanCmp x@(_, Bound xHighValue _) y@(Bound yLowValue _, _) =+ if boundsOverlapType x y /= Separate+ then EQ+ else if xHighValue <= yLowValue then LT else GT -intersectSpans :: (Ord a) => [(a, a)] -> [(a, a)] -> [(a, a)]-intersectSpans (x@(xlow, xup) : xs) (y@(ylow, yup) : ys) = +intersectSpans :: (Ord a) => [(Bound a, Bound a)] -> [(Bound a, Bound a)] -> [(Bound a, Bound a)]+intersectSpans (x@(xlow, xup@(Bound xUpValue _)) : xs) (y@(ylow, yup@(Bound yUpValue _)) : ys) = case spanCmp x y of- EQ -> (max xlow ylow, min xup yup) : if xup < yup- then intersectSpans xs (y : ys)- else intersectSpans (x : xs) ys+ EQ -> if (not . isEmptySpan $ intersectedSpan) then intersectedSpan : equalNext else equalNext LT -> intersectSpans xs (y : ys) GT -> intersectSpans (x : xs) ys-intersectSpans _ _ = []+ where+ intersectedSpan = (maxBoundsIntersection xlow ylow, minBoundsIntersection xup yup) -insertSpan :: Ord a => (a, b) -> [(a, b)] -> [(a, b)]-insertSpan = insertBy (comparing fst)+ lessThanNext = intersectSpans xs (y : ys)+ greaterThanNext = intersectSpans (x : xs) ys+ equalNext = if xUpValue < yUpValue then lessThanNext else greaterThanNext -sortSpans :: (Ord a) => [(a, a)] -> [(a, a)]-sortSpans = sortBy (comparing fst)+intersectSpans _ _ = [] + -- Assume that you are given a sorted list of spans-joinSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)]-joinSpans (f@(a, b) : s@(x, y) : xs) = - if succ b == x+joinSpans :: (Eq a, Enum a) => [(Bound a, Bound a)] -> [(Bound a, Bound a)]+joinSpans (f@(a, b) : s@(x, y) : xs) =+ if (succ . highestValueInUpperBound $ b) == lowestValueInLowerBound x then joinSpans $ (a, y) : xs else f : joinSpans (s : xs) joinSpans xs = xs -- Assume that you are given a sorted list of spans-unionSpans :: Ord a => [(a, a)] -> [(a, a)]-unionSpans (f@(a, b) : s@(x, y) : xs) = if isBetween x f - then unionSpans ((a, max b y) : xs)+unionSpans :: Ord a => [(Bound a, Bound a)] -> [(Bound a, Bound a)]+unionSpans (f@(a, b) : s@(_, y) : xs) = if boundsOverlapType f s /= Separate+ then unionSpans ((a, maxBounds b y) : xs) else f : unionSpans (s : xs) unionSpans xs = xs -- Assume that you are given a sorted and joined list of spans-invertSpans :: (Ord a, Enum a) => [(a, a)] -> [(a, a)]-invertSpans ((_, x) : s@(y, _) : xs) = (succ x, pred y) : invertSpans (s : xs)+invertSpans :: [(Bound a, Bound a)] -> [(Bound a, Bound a)]+invertSpans ((_, x) : s@(y, _) : xs) = (invertBound x, invertBound y) : invertSpans (s : xs) invertSpans _ = []--hasOverlaps :: (Ord a, Enum a) => [(a, a)] -> Bool-hasOverlaps xs = any isOverlapping (pairs xs)- where- isOverlapping ((x, y), (a, b)) = isBetween x (pred a, succ b) || isBetween a (pred x, succ y)
Data/Range/Util.hs view
@@ -1,29 +1,172 @@ {-# 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 --- 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.+import Data.List (transpose) -insertionSort :: (Ord a) => (a -> a -> Ordering) -> [a] -> [a] -> [a]+import Data.Range.Data++compareLower :: Ord a => Bound a -> Bound a -> Ordering+compareLower ab@(Bound a aType) bb@(Bound b _)+ | ab == bb = EQ+ | a == b = if aType == Inclusive then LT else GT+ | a < b = LT+ | otherwise = GT++compareHigher :: Ord a => Bound a -> Bound a -> Ordering+compareHigher ab@(Bound a aType) bb@(Bound b _)+ | ab == bb = EQ+ | a == b = if aType == Inclusive then GT else LT+ | 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+ | a == b = if aType == Exclusive then LT else GT+ | 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+ | a == b = if aType == Exclusive then GT else LT+ | a < b = LT+ | otherwise = GT++compareUpperToLower :: Ord a => Bound a -> Bound a -> Ordering+compareUpperToLower (Bound upper upperType) (Bound lower lowerType)+ | upper == lower = if upperType == Inclusive || lowerType == Inclusive then EQ else LT+ | upper < lower = LT+ | otherwise = GT++minBounds :: Ord a => Bound a -> Bound a -> Bound a+minBounds ao bo = if compareLower ao bo == LT then ao else bo++maxBounds :: Ord a => Bound a -> Bound a -> Bound a+maxBounds ao bo = if compareHigher ao bo == GT then ao else bo++minBoundsIntersection :: Ord a => Bound a -> Bound a -> Bound a+minBoundsIntersection ao bo = if compareLowerIntersection ao bo == LT then ao else bo++maxBoundsIntersection :: Ord a => Bound a -> Bound a -> Bound a+maxBoundsIntersection ao bo = if compareHigherIntersection ao bo == GT then ao else bo++insertionSort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] insertionSort comp xs ys = go xs ys where- go (f : fs) (s : ss) = case comp f s of + go (f : fs) (s : ss) = case comp f s of LT -> f : go fs (s : ss) EQ -> f : s : go fs ss GT -> s : go (f : fs) ss go [] z = z go z [] = z -isBetween :: (Ord a) => a -> (a, a) -> Bool-isBetween a (x, y) = (x <= a) && (a <= y)+invertBound :: Bound a -> Bound a+invertBound (Bound x Inclusive) = Bound x Exclusive+invertBound (Bound x Exclusive) = Bound x Inclusive -takeEvenly :: [a] -> [a] -> [a]-takeEvenly (a : as) (b : bs) = a : b : takeEvenly as bs-takeEvenly xs [] = xs-takeEvenly [] xs = xs- -pairs :: [a] -> [(a, a)]-pairs [] = []-pairs xs = zip xs (tail xs)+isEmptySpan :: Eq a => (Bound a, Bound a) -> Bool+isEmptySpan (Bound a aType, Bound b bType) = a == b && (aType == Exclusive || bType == Exclusive)++removeEmptySpans :: Eq a => [(Bound a, Bound a)] -> [(Bound a, Bound a)]+removeEmptySpans = filter (not . isEmptySpan)++boundsOverlapType :: Ord a => (Bound a, Bound a) -> (Bound a, Bound a) -> OverlapType+boundsOverlapType l@(ab@(Bound a _), bb@(Bound b _)) r@(xb@(Bound x _), yb@(Bound y _))+ | isEmptySpan l || isEmptySpan r = Separate+ | a == x = Overlap+ | 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+orOverlapType Adjoin _ = Adjoin+orOverlapType _ Adjoin = Adjoin+orOverlapType _ _ = Separate++pointJoinType :: BoundType -> BoundType -> OverlapType+pointJoinType Inclusive Inclusive = Overlap+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.+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++-- | 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+ | x == a = pointJoinType aType xType+ | a < y = Overlap+ | a == y = pointJoinType aType yType+ | otherwise = Separate++againstLowerBound :: Ord a => Bound a -> Bound a -> OverlapType+againstLowerBound (Bound a aType) (Bound lower lowerType)+ | lower == a = pointJoinType aType lowerType+ | lower < a = Overlap+ | otherwise = Separate++againstUpperBound :: Ord a => Bound a -> Bound a -> OverlapType+againstUpperBound (Bound a aType) (Bound upper upperType)+ | upper == a = pointJoinType aType upperType+ | a < upper = Overlap+ | otherwise = Separate++takeEvenly :: [[a]] -> [a]+takeEvenly = concat . transpose++lowestValueInLowerBound :: Enum a => Bound a -> a+lowestValueInLowerBound (Bound a Inclusive) = a+lowestValueInLowerBound (Bound a Exclusive) = succ a++highestValueInUpperBound :: Enum a => Bound a -> a+highestValueInUpperBound (Bound a Inclusive) = a+highestValueInUpperBound (Bound a Exclusive) = pred a
+ Data/Ranges.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE Safe #-}++-- | The primary interface to the range library.+--+-- 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.+--+-- = 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]+--+-- = Transforming ranges+--+-- '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+ -- $creation+ (+=+),+ (+=*),+ (*=+),+ (*=*),+ lbi,+ lbe,+ ubi,+ ube,+ inf,+ -- * Single-range predicates+ inRange,+ aboveRange,+ belowRange,+ rangesOverlap,+ rangesAdjoin,+ -- * Multi-range predicates+ inRanges,+ aboveRanges,+ belowRanges,+ -- * Set operations+ mergeRanges,+ union,+ intersection,+ difference,+ invert,+ -- * Enumerable methods+ fromRanges,+ joinRanges+) where++-- $setup+-- >>> import Data.Ranges+-- >>> import Data.Foldable (fold)++import Control.DeepSeq (NFData, rnf)++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 = 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 '<>':+--+-- >>> (1 +=+ 5 :: Ranges Integer) <> (3 +=+ 8)+-- Ranges [1 +=+ 8]+--+-- 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 'Range' values, with pre-built O(log n) membership,+-- O(1) above, and O(1) below predicates.+--+-- 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]+--+-- __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]+--+-- Use 'unRanges' to extract the underlying list.+data Ranges a = Ranges+ { 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 = showParen (i > 10) $ ("Ranges " ++) . shows (unRanges r)++-- | 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)++-- | 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 []+ mconcat = mkRanges . concatMap unRanges++-- ---------------------------------------------------------------------------+-- Construction operators+-- ---------------------------------------------------------------------------++-- | 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 [(Op.+=+) a b]++-- | Mathematically equivalent to @[x, y)@.+--+-- >>> 1 +=* 5 :: Ranges Integer+-- Ranges [1 +=* 5]+(+=*) :: Ord a => a -> a -> Ranges a+(+=*) a b = mkRanges [(Op.+=*) a b]++-- | Mathematically equivalent to @(x, y]@.+--+-- >>> 1 *=+ 5 :: Ranges Integer+-- Ranges [1 *=+ 5]+(*=+) :: Ord a => a -> a -> Ranges a+(*=+) a b = mkRanges [(Op.*=+) a b]++-- | Mathematically equivalent to @(x, y)@.+--+-- >>> 1 *=* 5 :: Ranges Integer+-- Ranges [1 *=* 5]+(*=*) :: Ord a => a -> a -> Ranges a+(*=*) a b = mkRanges [(Op.*=*) a b]++-- | Mathematically equivalent to @[x, ∞)@.+--+-- >>> lbi 5 :: Ranges Integer+-- Ranges [lbi 5]+lbi :: Ord a => a -> Ranges a+lbi = mkRanges . (:[]) . Op.lbi++-- | Mathematically equivalent to @(x, ∞)@.+lbe :: Ord a => a -> Ranges a+lbe = mkRanges . (:[]) . Op.lbe++-- | Mathematically equivalent to @(−∞, x]@.+ubi :: Ord a => a -> Ranges a+ubi = mkRanges . (:[]) . Op.ubi++-- | Mathematically equivalent to @(−∞, x)@.+ube :: Ord a => a -> Ranges a+ube = mkRanges . (:[]) . Op.ube++-- | The infinite range, covering all values.+inf :: Ord a => Ranges a+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 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+-- filter memberOf largeList+-- @+--+-- >>> inRanges (1 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 5+-- True+-- >>> inRanges (1 +=+ 10 <> 20 +=+ 30 :: Ranges Integer) 15+-- False+inRanges :: Ord a => Ranges a -> a -> Bool+inRanges = _rangesQuery++-- | 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 = _aboveQuery++-- | 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 = _belowQuery++-- ---------------------------------------------------------------------------+-- Set operations+-- ---------------------------------------------------------------------------++-- | 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 $ Alg.eval $+ Alg.intersection (Alg.const (unRanges a)) (Alg.const (unRanges b))++-- | 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 $ Alg.eval $+ Alg.difference (Alg.const (unRanges a)) (Alg.const (unRanges b))++-- | 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++-- ---------------------------------------------------------------------------+-- 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 = 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++-- | 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 . exportRangeMerge . joinRM . loadRanges . unRanges
+ DocTest.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest+ [ "Data/Range.hs"+ , "Data/Ranges.hs"+ , "Data/Range/Ord.hs"+ , "Data/Range/Parser.hs"+ , "Data/Range/Algebra.hs"+ ]
+ Test/Generators.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- Orphan instances are acceptable in test modules++module Test.Generators where++import Test.QuickCheck+import Control.Monad (liftM)++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+ , generateSpan+ , generateLowerBound+ , generateUpperBound+ , generateInfiniteRange+ ]+ where+ generateSingleton = liftM SingletonRange arbitrarySizedIntegral+ generateSpan = do+ 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+ [ (3, Alg.const <$> arbitrary)+ , (1, Alg.invert <$> arbitrary)+ , (1, Alg.union <$> arbitrary <*> arbitrary)+ , (1, Alg.intersection <$> arbitrary <*> arbitrary)+ , (1, Alg.difference <$> arbitrary <*> arbitrary)+ ]
Test/Range.hs view
@@ -4,18 +4,21 @@ module Main where -import Test.Framework (defaultMain, testGroup)+import Test.Framework (Test, defaultMain, testGroup) import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 -import Control.Applicative ((<$>), (<*>))-import Control.Monad (liftM) import System.Random -import Data.Range.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) deriving (Show)@@ -43,37 +46,19 @@ return $ SpanContains (begin, end) middle prop_span_contains :: SpanContains Integer -> Bool-prop_span_contains (SpanContains (begin, end) middle) = inRange (SpanRange begin end) middle+prop_span_contains (SpanContains (begin, end) middle) = inRange (SpanRange (Bound begin Inclusive) (Bound end Inclusive)) middle 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 ] -instance (Num a, Integral a, Ord a, Enum a) => Arbitrary (Range a) where- arbitrary = oneof- [ generateSingleton- , generateSpan- , generateLowerBound- , generateUpperBound- , generateInfiniteRange- ]- where- generateSingleton = liftM SingletonRange arbitrarySizedIntegral- generateSpan = do- first <- arbitrarySizedIntegral- second <- arbitrarySizedIntegral `suchThat` (> first)- return $ SpanRange first second- generateLowerBound = liftM LowerBoundRange arbitrarySizedIntegral- generateUpperBound = liftM UpperBoundRange arbitrarySizedIntegral- generateInfiniteRange :: Gen (Range a)- generateInfiniteRange = return InfiniteRange- -- an intersection of a value followed by a union of that value should be the identity. -- This is false. An intersection of a value followed by a union of that value should be -- the value itself.@@ -81,39 +66,37 @@ -- (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 ] -instance (Num a, Integral a, Ord a, Enum a) => Arbitrary (Alg.RangeExpr [Range a]) where- arbitrary = frequency- [ (3, Alg.const <$> arbitrary)- , (1, Alg.invert <$> arbitrary)- , (1, Alg.union <$> arbitrary <*> arbitrary)- , (1, Alg.intersection <$> arbitrary <*> arbitrary)- , (1, Alg.difference <$> arbitrary <*> arbitrary)- ]- 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 , test_algebra_equivalence ] ++ rangeMergeTestCases+ ++ rangeLawTestCases+ ++ rangeParserTestCases+ ++ rangeOrdTestCases+ ++ rangeBoundsTestCases +main :: IO () main = defaultMain tests
+ Test/RangeBounds.hs view
@@ -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+ ]
+ Test/RangeLaws.hs view
@@ -0,0 +1,170 @@+module Test.RangeLaws+ ( rangeLawTestCases+ ) where++import Test.Framework (Test, testGroup)+import Test.QuickCheck ()+import Test.Framework.Providers.QuickCheck2++import Data.Ranges+import Test.Generators ()++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- 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 :: Ranges Integer -> Bool+prop_mergeRanges_idempotent xs =+ mergeRanges (unRanges xs) `eq` xs++prop_union_idempotent :: Ranges Integer -> Bool+prop_union_idempotent xs =+ union xs xs `eq` xs++prop_intersection_idempotent :: Ranges Integer -> Bool+prop_intersection_idempotent xs =+ intersection xs xs `eq` xs++test_idempotency :: Test+test_idempotency = testGroup "idempotency"+ [ testProperty "mergeRanges is idempotent" prop_mergeRanges_idempotent+ , testProperty "union with self is self" prop_union_idempotent+ , testProperty "intersection with self is self" prop_intersection_idempotent+ ]++-- ---------------------------------------------------------------------------+-- Commutativity+-- ---------------------------------------------------------------------------++prop_union_commutative :: (Ranges Integer, Ranges Integer) -> Bool+prop_union_commutative (a, b) =+ union a b `eq` union b a++prop_intersection_commutative :: (Ranges Integer, Ranges Integer) -> Bool+prop_intersection_commutative (a, b) =+ intersection a b `eq` intersection b a++test_commutativity :: Test+test_commutativity = testGroup "commutativity"+ [ testProperty "union is commutative" prop_union_commutative+ , testProperty "intersection is commutative" prop_intersection_commutative+ ]++-- ---------------------------------------------------------------------------+-- Associativity+-- ---------------------------------------------------------------------------++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 :: (Ranges Integer, Ranges Integer, Ranges Integer) -> Bool+prop_intersection_associative (a, b, c) =+ intersection (intersection a b) c `eq` intersection a (intersection b c)++test_associativity :: Test+test_associativity = testGroup "associativity"+ [ testProperty "union is associative" prop_union_associative+ , testProperty "intersection is associative" prop_intersection_associative+ ]++-- ---------------------------------------------------------------------------+-- Distributivity+-- ---------------------------------------------------------------------------++prop_intersection_distributes_over_union+ :: (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+ :: (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)++test_distributivity :: Test+test_distributivity = testGroup "distributivity"+ [ testProperty "intersection distributes over union"+ prop_intersection_distributes_over_union+ , testProperty "union distributes over intersection"+ prop_union_distributes_over_intersection+ ]++-- ---------------------------------------------------------------------------+-- Identity laws+-- ---------------------------------------------------------------------------++prop_union_identity_empty :: Ranges Integer -> Bool+prop_union_identity_empty xs =+ union xs mempty `eq` xs++prop_intersection_identity_infinite :: Ranges Integer -> Bool+prop_intersection_identity_infinite xs =+ intersection xs inf `eq` xs++prop_union_absorb_infinite :: Ranges Integer -> Bool+prop_union_absorb_infinite xs =+ union xs inf `eq` inf++prop_intersection_absorb_empty :: Ranges Integer -> Bool+prop_intersection_absorb_empty xs =+ intersection xs mempty `eq` mempty++test_identity_absorption :: Test+test_identity_absorption = testGroup "identity and absorption"+ [ 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+ ]++-- ---------------------------------------------------------------------------+-- Difference as intersection with complement+-- ---------------------------------------------------------------------------++prop_difference_eq_intersection_invert+ :: (Ranges Integer, Ranges Integer) -> Bool+prop_difference_eq_intersection_invert (a, b) =+ difference a b `eq` intersection a (invert b)++test_difference :: Test+test_difference = testGroup "difference"+ [ testProperty "difference a b == intersection a (invert b)"+ prop_difference_eq_intersection_invert+ ]++-- ---------------------------------------------------------------------------+-- Double inversion+-- ---------------------------------------------------------------------------++prop_invert_twice_identity :: Ranges Integer -> Bool+prop_invert_twice_identity xs =+ invert (invert xs) `eq` xs++test_invert :: Test+test_invert = testGroup "invert"+ [ testProperty "inverting twice is identity" prop_invert_twice_identity+ ]++-- ---------------------------------------------------------------------------+-- Export+-- ---------------------------------------------------------------------------++rangeLawTestCases :: [Test]+rangeLawTestCases =+ [ test_idempotency+ , test_commutativity+ , test_associativity+ , test_distributivity+ , test_identity_absorption+ , test_difference+ , test_invert+ ]
Test/RangeMerge.hs view
@@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- This is only okay in test classes -module Test.RangeMerge +module Test.RangeMerge ( rangeMergeTestCases ) where -import Test.Framework (testGroup)+import Test.Framework (Test, testGroup) import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 @@ -13,25 +13,33 @@ import Data.Maybe (fromMaybe) import System.Random +import Data.Range.Data import Data.Range.RangeInternal+import Data.List (subsequences) instance (Num a, Integral a, Ord a, Random a) => Arbitrary (RangeMerge a) where+ shrink = fmap (foldr unionRangeMerges emptyRangeMerge) . init . subsequences . unmergeRM+ arbitrary = do upperBound <- maybeNumber possibleSpanStart <- arbitrarySizedIntegral spans <- generateSpanList (fromMaybe possibleSpanStart upperBound)- lowerBound <- oneof - [ fmap Just $ fmap ((+) $ maxMaybe (fmap snd $ lastMaybe spans) $ maxMaybe upperBound possibleSpanStart) $ choose (2, 100)+ lowerBound <- oneof+ [ fmap Just $ fmap ((+) $ maxMaybe (fmap (boundValue . snd) $ lastMaybe spans) $ maxMaybe upperBound possibleSpanStart) $ choose (2, 100) , return Nothing ]- return RM - { largestUpperBound = upperBound- , largestLowerBound = lowerBound + return RM+ { largestUpperBound = fmap (\x -> Bound x Inclusive) $ upperBound+ , largestLowerBound = fmap (\x -> Bound x Inclusive) $ lowerBound , spanRanges = spans } where maybeNumber = oneof [liftM Just arbitrarySizedIntegral, return Nothing] + maybeBound = do+ isInclusive <- arbitrary+ return (if isInclusive then Inclusive else Exclusive)+ lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing lastMaybe xs = Just . last $ xs@@ -40,22 +48,25 @@ maxMaybe Nothing x = x maxMaybe (Just y) x = max x y - generateSpanList :: (Num a, Ord a, Random a) => a -> Gen [(a, a)]+ generateSpanList :: (Num a, Ord a, Random a) => a -> Gen [(Bound a, Bound a)] generateSpanList start = do count <- choose (0, 10) helper count start where- helper :: (Num a, Ord a, Random a) => Integer -> a -> Gen [(a, a)]+ helper :: (Num a, Ord a, Random a) => Integer -> a -> Gen [(Bound a, Bound a)] helper 0 _ = return []- helper x start = do- first <- fmap (+start) $ choose (2, 100)+ helper x hStart = do+ first <- fmap (+hStart) $ choose (2, 100)+ firstBound <- maybeBound second <- fmap (+first) $ choose (2, 100)+ secondBound <- maybeBound remainder <- helper (x - 1) second- return $ (first, second) : remainder+ return $ (Bound first firstBound, Bound second secondBound) : remainder 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 ]@@ -63,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 ]@@ -73,37 +85,41 @@ 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 ] prop_intersection_with_empty_is_empty :: RangeMerge Integer -> Bool-prop_intersection_with_empty_is_empty rm = +prop_intersection_with_empty_is_empty rm = (rm `intersectionRangeMerges` emptyRangeMerge) == emptyRangeMerge prop_intersection_with_infinite_is_self :: RangeMerge Integer -> Bool-prop_intersection_with_infinite_is_self rm = +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 + [ testProperty "Intersection with empty is empty" prop_intersection_with_empty_is_empty+ , testProperty "Intersection with infinite is self" prop_intersection_with_infinite_is_self ] prop_demorgans_law_one :: (RangeMerge Integer, RangeMerge Integer) -> Bool-prop_demorgans_law_one (a, b) = +prop_demorgans_law_one (a, b) = (invertRM (a `unionRangeMerges` b)) == ((invertRM a) `intersectionRangeMerges` (invertRM b)) prop_demorgans_law_two :: (RangeMerge Integer, RangeMerge Integer) -> Bool-prop_demorgans_law_two (a, b) = +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)" prop_demorgans_law_one- , testProperty "DeMorgan Part 2: not (a and b) == (not a) or (not b)" prop_demorgans_law_two+ [ 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
+ Test/RangeOrd.hs view
@@ -0,0 +1,250 @@+module Test.RangeOrd+ ( rangeOrdTestCases+ ) where++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 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+-- ---------------------------------------------------------------------------++-- Verify that compare is consistent with Eq for KeyRange+keyEqOrdConsistent :: Ord a => KeyRange a -> KeyRange a -> Bool+keyEqOrdConsistent x y = (x == y) == (compare x y == EQ)++-- Verify that compare is consistent with Eq for SortedRange+sortEqOrdConsistent :: Ord a => SortedRange a -> SortedRange a -> Bool+sortEqOrdConsistent x y = (x == y) == (compare x y == EQ)++-- ---------------------------------------------------------------------------+-- KeyRange: unit tests+-- ---------------------------------------------------------------------------++-- Constructor ordering: SingletonRange < SpanRange < LowerBoundRange <+-- UpperBoundRange < InfiniteRange+prop_key_constructor_singleton_lt_span :: Bool+prop_key_constructor_singleton_lt_span =+ KeyRange (SingletonRange (0 :: Integer)) < KeyRange (spanI 0 0)++prop_key_constructor_span_lt_lower :: Bool+prop_key_constructor_span_lt_lower =+ KeyRange (spanI 0 (0 :: Integer)) < KeyRange (lbiR 0)++prop_key_constructor_lower_lt_upper :: Bool+prop_key_constructor_lower_lt_upper =+ KeyRange (lbiR (0 :: Integer)) < KeyRange (ubiR 0)++prop_key_constructor_upper_lt_infinite :: Bool+prop_key_constructor_upper_lt_infinite =+ KeyRange (ubiR (0 :: Integer)) < KeyRange (infR :: Range Integer)++-- Within the same constructor, compare by fields+prop_key_singletons_by_value :: Bool+prop_key_singletons_by_value =+ KeyRange (SingletonRange (3 :: Integer)) < KeyRange (SingletonRange 5)++prop_key_spans_by_lower_first :: Bool+prop_key_spans_by_lower_first =+ 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 (spanI (1 :: Integer) 5) < KeyRange (spanI 1 10)++prop_key_lower_bounds_by_value :: Bool+prop_key_lower_bounds_by_value =+ KeyRange (lbiR (1 :: Integer)) < KeyRange (lbiR 2)++prop_key_upper_bounds_by_value :: Bool+prop_key_upper_bounds_by_value =+ KeyRange (ubiR (1 :: Integer)) < KeyRange (ubiR 2)++prop_key_infinite_eq_infinite :: Bool+prop_key_infinite_eq_infinite =+ compare (KeyRange (infR :: Range Integer)) (KeyRange infR) == EQ++test_keyrange_unit :: Test+test_keyrange_unit = testGroup "KeyRange unit"+ [ testProperty "SingletonRange < SpanRange" prop_key_constructor_singleton_lt_span+ , testProperty "SpanRange < LowerBoundRange" prop_key_constructor_span_lt_lower+ , testProperty "LowerBoundRange < UpperBoundRange" prop_key_constructor_lower_lt_upper+ , testProperty "UpperBoundRange < InfiniteRange" prop_key_constructor_upper_lt_infinite+ , testProperty "singletons ordered by value" prop_key_singletons_by_value+ , testProperty "spans ordered by lower bound first" prop_key_spans_by_lower_first+ , testProperty "spans ordered by upper bound when lower equal" prop_key_spans_by_upper_on_equal_lower+ , testProperty "lower bounds ordered by value" prop_key_lower_bounds_by_value+ , testProperty "upper bounds ordered by value" prop_key_upper_bounds_by_value+ , testProperty "InfiniteRange equals itself" prop_key_infinite_eq_infinite+ ]++-- ---------------------------------------------------------------------------+-- KeyRange: QuickCheck properties+-- ---------------------------------------------------------------------------++prop_key_reflexive :: Range Integer -> Bool+prop_key_reflexive r = compare (KeyRange r) (KeyRange r) == EQ++prop_key_eq_ord_consistent :: Range Integer -> Range Integer -> Bool+prop_key_eq_ord_consistent x y = keyEqOrdConsistent (KeyRange x) (KeyRange y)++prop_key_antisymmetric :: Range Integer -> Range Integer -> Bool+prop_key_antisymmetric x y =+ case compare (KeyRange x) (KeyRange y) of+ LT -> compare (KeyRange y) (KeyRange x) == GT+ GT -> compare (KeyRange y) (KeyRange x) == LT+ EQ -> compare (KeyRange y) (KeyRange x) == EQ++prop_key_set_dedup :: [Range Integer] -> Bool+prop_key_set_dedup rs =+ -- Every range we put in we can get back out; Set operations work+ let keyed = map KeyRange rs+ s = Set.fromList keyed+ in all (`Set.member` s) keyed++prop_key_map_lookup :: Range Integer -> String -> Bool+prop_key_map_lookup r v =+ Map.lookup (KeyRange r) (Map.singleton (KeyRange r) v) == Just v++test_keyrange_properties :: Test+test_keyrange_properties = testGroup "KeyRange properties"+ [ testProperty "reflexive" prop_key_reflexive+ , testProperty "Eq/Ord consistent" prop_key_eq_ord_consistent+ , testProperty "antisymmetric" prop_key_antisymmetric+ , testProperty "usable in Set" prop_key_set_dedup+ , testProperty "usable as Map key" prop_key_map_lookup+ ]++-- ---------------------------------------------------------------------------+-- SortedRange: unit tests+-- ---------------------------------------------------------------------------++-- 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 (ubiR (0 :: Integer)) < SortedRange (lbiR 0)++prop_sorted_infinite_before_lower :: Bool+prop_sorted_infinite_before_lower =+ SortedRange (infR :: Range Integer) < SortedRange (lbiR 1)++-- Spans ordered by lower bound+prop_sorted_singletons_by_value :: Bool+prop_sorted_singletons_by_value =+ SortedRange (SingletonRange (3 :: Integer)) < SortedRange (SingletonRange 5)++prop_sorted_spans_by_lower :: Bool+prop_sorted_spans_by_lower =+ 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 (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 (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 [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+prop_sorted_singleton_eq_degenerate_span =+ compare (SortedRange (SingletonRange (5 :: Integer)))+ (SortedRange (SpanRange (Bound 5 Inclusive) (Bound 5 Inclusive)))+ == EQ++test_sortedrange_unit :: Test+test_sortedrange_unit = testGroup "SortedRange unit"+ [ testProperty "UpperBoundRange before LowerBoundRange" prop_sorted_upper_before_span+ , testProperty "InfiniteRange before LowerBoundRange" prop_sorted_infinite_before_lower+ , testProperty "singletons ordered by value" prop_sorted_singletons_by_value+ , testProperty "spans ordered by lower bound" prop_sorted_spans_by_lower+ , testProperty "tiebreak by upper bound" prop_sorted_tiebreak_by_upper+ , testProperty "UpperBoundRange before InfiniteRange" prop_sorted_upper_before_infinite+ , testProperty "sortOn gives display order" prop_sorted_display_order+ , testProperty "singleton equals degenerate span" prop_sorted_singleton_eq_degenerate_span+ ]++-- ---------------------------------------------------------------------------+-- SortedRange: QuickCheck properties+-- ---------------------------------------------------------------------------++prop_sorted_reflexive :: Range Integer -> Bool+prop_sorted_reflexive r = compare (SortedRange r) (SortedRange r) == EQ++prop_sorted_eq_ord_consistent :: Range Integer -> Range Integer -> Bool+prop_sorted_eq_ord_consistent x y = sortEqOrdConsistent (SortedRange x) (SortedRange y)++prop_sorted_antisymmetric :: Range Integer -> Range Integer -> Bool+prop_sorted_antisymmetric x y =+ case compare (SortedRange x) (SortedRange y) of+ LT -> compare (SortedRange y) (SortedRange x) == GT+ GT -> compare (SortedRange y) (SortedRange x) == LT+ EQ -> compare (SortedRange y) (SortedRange x) == EQ++-- Sorting twice is idempotent+prop_sorted_sort_idempotent :: [Range Integer] -> Bool+prop_sorted_sort_idempotent rs =+ sortOn SortedRange (sortOn SortedRange rs) == sortOn SortedRange rs++test_sortedrange_properties :: Test+test_sortedrange_properties = testGroup "SortedRange properties"+ [ testProperty "reflexive" prop_sorted_reflexive+ , testProperty "Eq/Ord consistent" prop_sorted_eq_ord_consistent+ , testProperty "antisymmetric" prop_sorted_antisymmetric+ , testProperty "sort is idempotent" prop_sorted_sort_idempotent+ ]++-- ---------------------------------------------------------------------------+-- Export+-- ---------------------------------------------------------------------------++rangeOrdTestCases :: [Test]+rangeOrdTestCases =+ [ test_keyrange_unit+ , test_keyrange_properties+ , test_sortedrange_unit+ , test_sortedrange_properties+ ]
+ Test/RangeParser.hs view
@@ -0,0 +1,227 @@+module Test.RangeParser+ ( rangeParserTestCases+ ) where++import Test.Framework (Test, testGroup)+import Test.QuickCheck+import Test.Framework.Providers.QuickCheck2++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 == mergeRanges expected+ Left _ -> False++shouldFail :: String -> Bool+shouldFail input = case (parseRanges input :: Either ParseError (Ranges Integer)) of+ Left _ -> True+ Right _ -> False++-- ---------------------------------------------------------------------------+-- Haddock example tests+-- ---------------------------------------------------------------------------++prop_haddock_example :: Bool+prop_haddock_example = shouldParse "-5,8-10,13-15,20-"+ [ UpperBoundRange (Bound 5 Inclusive)+ , SpanRange (Bound 8 Inclusive) (Bound 10 Inclusive)+ , SpanRange (Bound 13 Inclusive) (Bound 15 Inclusive)+ , LowerBoundRange (Bound 20 Inclusive)+ ]++test_haddock :: Test+test_haddock = testGroup "haddock examples"+ [ testProperty "documented example parses correctly" prop_haddock_example+ ]++-- ---------------------------------------------------------------------------+-- Singleton ranges+-- ---------------------------------------------------------------------------++prop_parse_singleton :: Positive Integer -> Bool+prop_parse_singleton (Positive n) = shouldParse (show n) [SingletonRange n]++prop_parse_singleton_zero :: Bool+prop_parse_singleton_zero = shouldParse "0" [SingletonRange 0]++test_singletons :: Test+test_singletons = testGroup "singleton ranges"+ [ testProperty "positive integer parses as singleton" prop_parse_singleton+ , testProperty "zero parses as singleton" prop_parse_singleton_zero+ ]++-- ---------------------------------------------------------------------------+-- Span ranges+-- ---------------------------------------------------------------------------++prop_parse_span :: (Positive Integer, Positive Integer) -> Bool+prop_parse_span (Positive a, Positive b) =+ shouldParse (show a ++ "-" ++ show b)+ [SpanRange (Bound a Inclusive) (Bound b Inclusive)]++test_spans :: Test+test_spans = testGroup "span ranges"+ [ testProperty "a-b parses as span" prop_parse_span+ ]++-- ---------------------------------------------------------------------------+-- Bound ranges+-- ---------------------------------------------------------------------------++prop_parse_lower_bound :: Positive Integer -> Bool+prop_parse_lower_bound (Positive n) =+ shouldParse (show n ++ "-") [LowerBoundRange (Bound n Inclusive)]++prop_parse_upper_bound :: Positive Integer -> Bool+prop_parse_upper_bound (Positive n) =+ shouldParse ("-" ++ show n) [UpperBoundRange (Bound n Inclusive)]++test_bounds :: Test+test_bounds = testGroup "bound ranges"+ [ testProperty "n- parses as lower bound" prop_parse_lower_bound+ , testProperty "-n parses as upper bound" prop_parse_upper_bound+ ]++-- ---------------------------------------------------------------------------+-- Wildcard / infinite range+-- ---------------------------------------------------------------------------++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]++test_wildcard :: Test+test_wildcard = testGroup "wildcard / infinite range"+ [ testProperty "* parses as InfiniteRange" prop_parse_wildcard+ , testProperty "* in union parses correctly" prop_parse_wildcard_in_union+ ]++-- ---------------------------------------------------------------------------+-- Union (comma-separated)+-- ---------------------------------------------------------------------------++prop_parse_union :: Bool+prop_parse_union = shouldParse "1,2,3"+ [SingletonRange 1, SingletonRange 2, SingletonRange 3]++prop_parse_mixed_union :: Bool+prop_parse_mixed_union = shouldParse "5,10-20,30-"+ [ SingletonRange 5+ , SpanRange (Bound 10 Inclusive) (Bound 20 Inclusive)+ , LowerBoundRange (Bound 30 Inclusive)+ ]++test_union :: Test+test_union = testGroup "union (comma-separated)"+ [ testProperty "singletons separated by commas" prop_parse_union+ , testProperty "mixed types separated by commas" prop_parse_mixed_union+ ]++-- ---------------------------------------------------------------------------+-- Edge cases and invalid inputs+-- ---------------------------------------------------------------------------++prop_empty_string_parses :: Bool+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" 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 (Ranges Integer)) of+ Right result -> result == mempty+ _ -> False++test_edge_cases :: Test+test_edge_cases = testGroup "edge cases"+ [ testProperty "empty string produces empty list" prop_empty_string_parses+ , testProperty "non-range input produces empty list" prop_non_range_input_parses_empty+ ]++-- ---------------------------------------------------------------------------+-- 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 = ".." }+ 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+ ]+ Left _ -> False++test_custom :: Test+test_custom = testGroup "custom parser args"+ [ testProperty "custom separators work" prop_custom_separators+ ]++-- ---------------------------------------------------------------------------+-- Export+-- ---------------------------------------------------------------------------++rangeParserTestCases :: [Test]+rangeParserTestCases =+ [ test_haddock+ , test_singletons+ , test_spans+ , test_bounds+ , test_wildcard+ , test_union+ , test_edge_cases+ , test_invalid+ , test_custom+ ]
range.cabal view
@@ -10,20 +10,26 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.2.0+version: 1.0.0.0 -- A short (one-line) description of the package.-synopsis: This has a bunch of code for specifying and managing ranges in your code.+synopsis: An efficient and versatile range library. -- A longer description of the package.-description: range is built to allow you to use ranges in your code quickly and- efficiently. There are many occasions where you will want to check if- certain values are within a range and this library will make it- trivial for you to do so. It also attempts to do so in the most- efficient way possible.+description: The range library alows the use of performant and versatile ranges in your code.+ It supports bounded and unbounded ranges, ranges in a nested manner (like library+ versions), an efficient algebra of range computation and even a simplified interface+ for ranges for the common cases. This library is far more efficient than using the+ default Data.List functions to approximate range behaviour. Performance is the major+ value offering of this library. -homepage: https://bitbucket.org/robertmassaioli/range+ If this is your first time using this library it is highly recommended that you start+ with "Data.Range"; it contains the basics of this library that meet most use+ cases. +homepage: https://github.com/robertmassaioli/range+bug-reports: https://github.com/robertmassaioli/range/issues+ -- The license under which the package is released. license: MIT @@ -45,19 +51,24 @@ build-type: Simple -- Constraint on the version of Cabal needed to build this package.-cabal-version: >=1.8+cabal-version: >=1.10 +source-repository head+ type: git+ location: https://github.com/robertmassaioli/range + library -- Modules exported by the library.- exposed-modules: Data.Range.Range- , Data.Range.NestedRange- , Data.Range.RangeTree+ exposed-modules: Data.Range+ , Data.Ranges+ , Data.Range.Ord , Data.Range.Parser , Data.Range.Algebra -- Modules included in this library but not exported. other-modules: Data.Range.Data+ , Data.Range.Operators , Data.Range.RangeInternal , Data.Range.Spans , Data.Range.Util@@ -67,10 +78,13 @@ -- Other library packages from which modules are imported.- build-depends: base >= 4.5 && < 5- , parsec >= 3- , free >=4.12+ build-depends: base >= 4.7 && < 5+ , parsec >= 3 && < 4+ , free >= 4.12 && < 6+ , deepseq >= 1.4 && < 2+ , containers >= 0.5 && < 1 + default-language: Haskell2010 ghc-options: -Wall @@ -78,12 +92,56 @@ type: exitcode-stdio-1.0 main-is: Test/Range.hs other-modules: Test.RangeMerge+ , 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 , test-framework-quickcheck2 >= 0.2 && < 0.4 , test-framework >= 0.4 && < 0.9 , random >= 1.0- , free >= 4.12+ , free >= 4.12+ , deepseq >= 1.4 && < 2+ , parsec >= 3 && < 4+ , containers >= 0.5 && < 1 , range- ghc-options: -rtsopts -Wall -fno-enable-rewrite-rules+ default-language: Haskell2010+ ghc-options: -rtsopts -Wall++test-suite doctest-range+ type: exitcode-stdio-1.0+ main-is: DocTest.hs+ build-depends: base >= 4.7 && < 5+ , doctest >= 0.20 && < 1+ , range+ default-language: Haskell2010+ ghc-options: -Wall++benchmark bench-range+ type: exitcode-stdio-1.0+ main-is: Bench/Range.hs+ build-depends: base >= 4.7 && < 5+ , range+ , tasty-bench >= 0.3 && < 1+ , deepseq >= 1.4 && < 2+ , free >= 4.12 && < 6+ , parsec >= 3 && < 4+ , containers >= 0.5 && < 1+ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts