diff --git a/Bench/Range.hs b/Bench/Range.hs new file mode 100644 --- /dev/null +++ b/Bench/Range.hs @@ -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) + ] + ] + ] diff --git a/Data/Range.hs b/Data/Range.hs new file mode 100644 --- /dev/null +++ b/Data/Range.hs @@ -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 diff --git a/Data/Range/Algebra.hs b/Data/Range/Algebra.hs --- a/Data/Range/Algebra.hs +++ b/Data/Range/Algebra.hs @@ -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 +-- +-- 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 diff --git a/Data/Range/Algebra/Internal.hs b/Data/Range/Algebra/Internal.hs --- a/Data/Range/Algebra/Internal.hs +++ b/Data/Range/Algebra/Internal.hs @@ -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 diff --git a/Data/Range/Algebra/Predicate.hs b/Data/Range/Algebra/Predicate.hs --- a/Data/Range/Algebra/Predicate.hs +++ b/Data/Range/Algebra/Predicate.hs @@ -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 diff --git a/Data/Range/Algebra/Range.hs b/Data/Range/Algebra/Range.hs --- a/Data/Range/Algebra/Range.hs +++ b/Data/Range/Algebra/Range.hs @@ -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) diff --git a/Data/Range/Data.hs b/Data/Range/Data.hs --- a/Data/Range/Data.hs +++ b/Data/Range/Data.hs @@ -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" diff --git a/Data/Range/NestedRange.hs b/Data/Range/NestedRange.hs deleted file mode 100644 --- a/Data/Range/NestedRange.hs +++ /dev/null @@ -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 diff --git a/Data/Range/Operators.hs b/Data/Range/Operators.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Operators.hs @@ -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 diff --git a/Data/Range/Ord.hs b/Data/Range/Ord.hs new file mode 100644 --- /dev/null +++ b/Data/Range/Ord.hs @@ -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 diff --git a/Data/Range/Parser.hs b/Data/Range/Parser.hs --- a/Data/Range/Parser.hs +++ b/Data/Range/Parser.hs @@ -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) diff --git a/Data/Range/Range.hs b/Data/Range/Range.hs deleted file mode 100644 --- a/Data/Range/Range.hs +++ /dev/null @@ -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 diff --git a/Data/Range/RangeInternal.hs b/Data/Range/RangeInternal.hs --- a/Data/Range/RangeInternal.hs +++ b/Data/Range/RangeInternal.hs @@ -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) diff --git a/Data/Range/RangeTree.hs b/Data/Range/RangeTree.hs deleted file mode 100644 --- a/Data/Range/RangeTree.hs +++ /dev/null @@ -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 diff --git a/Data/Range/Spans.hs b/Data/Range/Spans.hs --- a/Data/Range/Spans.hs +++ b/Data/Range/Spans.hs @@ -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) diff --git a/Data/Range/Util.hs b/Data/Range/Util.hs --- a/Data/Range/Util.hs +++ b/Data/Range/Util.hs @@ -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 diff --git a/Data/Ranges.hs b/Data/Ranges.hs new file mode 100644 --- /dev/null +++ b/Data/Ranges.hs @@ -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 diff --git a/DocTest.hs b/DocTest.hs new file mode 100644 --- /dev/null +++ b/DocTest.hs @@ -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" + ] diff --git a/Test/Generators.hs b/Test/Generators.hs new file mode 100644 --- /dev/null +++ b/Test/Generators.hs @@ -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) + ] diff --git a/Test/Range.hs b/Test/Range.hs --- a/Test/Range.hs +++ b/Test/Range.hs @@ -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 diff --git a/Test/RangeBounds.hs b/Test/RangeBounds.hs new file mode 100644 --- /dev/null +++ b/Test/RangeBounds.hs @@ -0,0 +1,123 @@ +module Test.RangeBounds + ( rangeBoundsTestCases + ) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Positive(..), Property, (==>)) + +import Data.Ranges +import Test.Generators () + +-- --------------------------------------------------------------------------- +-- inRange: exclusive vs inclusive endpoint behaviour +-- --------------------------------------------------------------------------- + +-- Exclusive lower bound: the boundary value itself is NOT in the range. +prop_exclusive_lower_excludes_endpoint :: Positive Integer -> Bool +prop_exclusive_lower_excludes_endpoint (Positive x) = + not $ inRange (SpanRange (Bound x Exclusive) (Bound (x + 10) Inclusive)) x + +-- Inclusive lower bound: the boundary value IS in the range. +prop_inclusive_lower_includes_endpoint :: Positive Integer -> Bool +prop_inclusive_lower_includes_endpoint (Positive x) = + inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Inclusive)) x + +-- Exclusive upper bound: the boundary value itself is NOT in the range. +prop_exclusive_upper_excludes_endpoint :: Positive Integer -> Bool +prop_exclusive_upper_excludes_endpoint (Positive x) = + not $ inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Exclusive)) (x + 10) + +-- Inclusive upper bound: the boundary value IS in the range. +prop_inclusive_upper_includes_endpoint :: Positive Integer -> Bool +prop_inclusive_upper_includes_endpoint (Positive x) = + inRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Inclusive)) (x + 10) + +test_inrange_endpoints :: Test +test_inrange_endpoints = testGroup "inRange endpoint inclusion" + [ testProperty "exclusive lower bound excludes endpoint" prop_exclusive_lower_excludes_endpoint + , testProperty "inclusive lower bound includes endpoint" prop_inclusive_lower_includes_endpoint + , testProperty "exclusive upper bound excludes endpoint" prop_exclusive_upper_excludes_endpoint + , testProperty "inclusive upper bound includes endpoint" prop_inclusive_upper_includes_endpoint + ] + +-- --------------------------------------------------------------------------- +-- aboveRange / belowRange: exclusive bound semantics +-- --------------------------------------------------------------------------- + +-- A value equal to an exclusive upper bound is ABOVE the range +-- (the range ends strictly before that value). +prop_above_exclusive_upper :: Positive Integer -> Bool +prop_above_exclusive_upper (Positive x) = + aboveRange (SpanRange (Bound x Inclusive) (Bound (x + 10) Exclusive)) (x + 10) + +-- A value equal to an exclusive lower bound is BELOW the range +-- (the range starts strictly after that value). +prop_below_exclusive_lower :: Positive Integer -> Bool +prop_below_exclusive_lower (Positive x) = + belowRange (SpanRange (Bound x Exclusive) (Bound (x + 10) Inclusive)) x + +test_above_below_exclusive :: Test +test_above_below_exclusive = testGroup "aboveRange/belowRange with exclusive bounds" + [ testProperty "value at exclusive upper bound is above range" prop_above_exclusive_upper + , testProperty "value at exclusive lower bound is below range" prop_below_exclusive_lower + ] + +-- --------------------------------------------------------------------------- +-- Half-infinite ranges: exclusive bounds +-- --------------------------------------------------------------------------- + +-- lbe: exclusive lower bound does not include the endpoint but includes succ +prop_lbe_excludes_endpoint :: Integer -> Bool +prop_lbe_excludes_endpoint x = + not (inRange (LowerBoundRange (Bound x Exclusive)) x) + && inRange (LowerBoundRange (Bound x Exclusive)) (x + 1) + +-- ube: exclusive upper bound does not include the endpoint but includes pred +prop_ube_excludes_endpoint :: Integer -> Bool +prop_ube_excludes_endpoint x = + not (inRange (UpperBoundRange (Bound x Exclusive)) x) + && inRange (UpperBoundRange (Bound x Exclusive)) (x - 1) + +test_halfinfinte_exclusive :: Test +test_halfinfinte_exclusive = testGroup "half-infinite exclusive bounds" + [ testProperty "lbe excludes endpoint, includes successor" prop_lbe_excludes_endpoint + , testProperty "ube excludes endpoint, includes predecessor" prop_ube_excludes_endpoint + ] + +-- --------------------------------------------------------------------------- +-- Mutual exclusion: belowRanges / inRanges / aboveRanges +-- --------------------------------------------------------------------------- + +-- For any point and any non-empty Ranges, no two of below/in/above can be +-- simultaneously true. (A point in the gap between disjoint ranges is none +-- of the three — that is also correct.) +-- +-- The non-empty guard is necessary: for Ranges [], belowRanges and aboveRanges +-- both return True vacuously (there are no ranges to fail to be above/below), +-- so the mutual-exclusion invariant only holds for non-empty range sets. +prop_below_in_above_mutually_exclusive :: (Integer, Ranges Integer) -> Property +prop_below_in_above_mutually_exclusive (x, rs) = + not (null (unRanges rs)) ==> + let b = belowRanges rs x + i = inRanges rs x + a = aboveRanges rs x + in not (b && i) && not (a && i) && not (b && a) + +test_partition :: Test +test_partition = testGroup "below/in/above mutual exclusion" + [ testProperty "at most one of belowRanges/inRanges/aboveRanges holds" + prop_below_in_above_mutually_exclusive + ] + +-- --------------------------------------------------------------------------- +-- Export +-- --------------------------------------------------------------------------- + +rangeBoundsTestCases :: [Test] +rangeBoundsTestCases = + [ test_inrange_endpoints + , test_above_below_exclusive + , test_halfinfinte_exclusive + , test_partition + ] diff --git a/Test/RangeLaws.hs b/Test/RangeLaws.hs new file mode 100644 --- /dev/null +++ b/Test/RangeLaws.hs @@ -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 + ] diff --git a/Test/RangeMerge.hs b/Test/RangeMerge.hs --- a/Test/RangeMerge.hs +++ b/Test/RangeMerge.hs @@ -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 diff --git a/Test/RangeOrd.hs b/Test/RangeOrd.hs new file mode 100644 --- /dev/null +++ b/Test/RangeOrd.hs @@ -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 + ] diff --git a/Test/RangeParser.hs b/Test/RangeParser.hs new file mode 100644 --- /dev/null +++ b/Test/RangeParser.hs @@ -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 + ] diff --git a/range.cabal b/range.cabal --- a/range.cabal +++ b/range.cabal @@ -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