diff --git a/Data/Range/Data.hs b/Data/Range/Data.hs --- a/Data/Range/Data.hs +++ b/Data/Range/Data.hs @@ -16,7 +16,7 @@ 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, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance NFData BoundType @@ -25,7 +25,7 @@ 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, Show, Generic) + } deriving (Eq, Ord, Show, Generic) instance NFData a => NFData (Bound a) 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,141 @@ +{-# 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.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 +-- +-- @ +-- import Data.Range.Ord (SortedRange(..)) +-- import Data.List (sortOn) +-- +-- displayRanges :: Ord a => [Range a] -> [Range a] +-- displayRanges = sortOn SortedRange +-- @ +module Data.Range.Ord + ( KeyRange(..) + , SortedRange(..) + ) where + +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. +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. +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/Test/Generators.hs b/Test/Generators.hs new file mode 100644 --- /dev/null +++ b/Test/Generators.hs @@ -0,0 +1,39 @@ +{-# 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.Range +import qualified Data.Range.Algebra as Alg + +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 $ first +=+ second + generateLowerBound = liftM lbi arbitrarySizedIntegral + generateUpperBound = liftM ubi arbitrarySizedIntegral + generateInfiniteRange :: Gen (Range a) + generateInfiniteRange = return InfiniteRange + +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 @@ -8,14 +8,16 @@ import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 -import Control.Applicative ((<$>), (<*>)) -import Control.Monad (liftM) import System.Random import Data.Range import qualified Data.Range.Algebra as Alg import Test.RangeMerge +import Test.RangeLaws +import Test.RangeParser +import Test.RangeOrd +import Test.Generators () data UnequalPair a = UnequalPair (a, a) deriving (Show) @@ -55,25 +57,6 @@ , 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 $ first +=+ second - generateLowerBound = liftM lbi arbitrarySizedIntegral - generateUpperBound = liftM ubi 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. @@ -89,15 +72,6 @@ [ 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 @@ -115,5 +89,8 @@ , test_algebra_equivalence ] ++ rangeMergeTestCases + ++ rangeLawTestCases + ++ rangeParserTestCases + ++ rangeOrdTestCases main = defaultMain tests diff --git a/Test/RangeLaws.hs b/Test/RangeLaws.hs new file mode 100644 --- /dev/null +++ b/Test/RangeLaws.hs @@ -0,0 +1,178 @@ +module Test.RangeLaws + ( rangeLawTestCases + ) where + +import Test.Framework (Test, testGroup) +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 + +import Data.Range +import Test.Generators () + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- Sort before comparing so that order differences don't cause false failures. +-- mergeRanges produces a canonical form, so we use it to normalise both sides. +canonical :: Ord a => [Range a] -> [Range a] +canonical = mergeRanges + +eq :: (Ord a) => [Range a] -> [Range a] -> Bool +eq a b = canonical a == canonical b + +-- --------------------------------------------------------------------------- +-- Idempotency +-- --------------------------------------------------------------------------- + +prop_mergeRanges_idempotent :: [Range Integer] -> Bool +prop_mergeRanges_idempotent xs = + mergeRanges (mergeRanges xs) == mergeRanges xs + +prop_union_idempotent :: [Range Integer] -> Bool +prop_union_idempotent xs = + union xs xs `eq` xs + +prop_intersection_idempotent :: [Range 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 :: ([Range Integer], [Range Integer]) -> Bool +prop_union_commutative (a, b) = + union a b `eq` union b a + +prop_intersection_commutative :: ([Range Integer], [Range Integer]) -> Bool +prop_intersection_commutative (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 :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +prop_union_associative (a, b, c) = + union (union a b) c `eq` union a (union b c) + +prop_intersection_associative :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +prop_intersection_associative (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 + :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +prop_intersection_distributes_over_union (a, b, c) = + intersection a (union b c) `eq` union (intersection a b) (intersection a c) + +prop_union_distributes_over_intersection + :: ([Range Integer], [Range Integer], [Range Integer]) -> Bool +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 +-- --------------------------------------------------------------------------- + +-- The empty range list acts as the identity for union +prop_union_identity_empty :: [Range Integer] -> Bool +prop_union_identity_empty xs = + union xs [] `eq` xs + +-- InfiniteRange acts as the identity for intersection +prop_intersection_identity_infinite :: [Range Integer] -> Bool +prop_intersection_identity_infinite xs = + intersection xs [InfiniteRange] `eq` xs + +-- Union with InfiniteRange absorbs everything +prop_union_absorb_infinite :: [Range Integer] -> Bool +prop_union_absorb_infinite xs = + union xs [InfiniteRange] `eq` [InfiniteRange] + +-- Intersection with empty absorbs everything +prop_intersection_absorb_empty :: [Range Integer] -> Bool +prop_intersection_absorb_empty xs = + intersection xs [] `eq` [] + +test_identity_absorption :: Test +test_identity_absorption = testGroup "identity and absorption" + [ testProperty "union with [] is identity" prop_union_identity_empty + , testProperty "intersection with InfiniteRange is identity" prop_intersection_identity_infinite + , testProperty "union with InfiniteRange absorbs" prop_union_absorb_infinite + , testProperty "intersection with [] absorbs" prop_intersection_absorb_empty + ] + +-- --------------------------------------------------------------------------- +-- Difference as intersection with complement +-- --------------------------------------------------------------------------- + +prop_difference_eq_intersection_invert + :: ([Range Integer], [Range 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 :: [Range 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/RangeOrd.hs b/Test/RangeOrd.hs new file mode 100644 --- /dev/null +++ b/Test/RangeOrd.hs @@ -0,0 +1,226 @@ +module Test.RangeOrd + ( rangeOrdTestCases + ) where + +import Data.List (sort, 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.Range +import Data.Range.Ord + +import Test.Generators () + +-- --------------------------------------------------------------------------- +-- 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 (0 +=+ 0) + +prop_key_constructor_span_lt_lower :: Bool +prop_key_constructor_span_lt_lower = + KeyRange (0 +=+ (0 :: Integer)) < KeyRange (lbi 0) + +prop_key_constructor_lower_lt_upper :: Bool +prop_key_constructor_lower_lt_upper = + KeyRange (lbi (0 :: Integer)) < KeyRange (ubi 0) + +prop_key_constructor_upper_lt_infinite :: Bool +prop_key_constructor_upper_lt_infinite = + KeyRange (ubi (0 :: Integer)) < KeyRange (inf :: 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 ((1 :: Integer) +=+ 10) < KeyRange (2 +=+ 10) + +prop_key_spans_by_upper_on_equal_lower :: Bool +prop_key_spans_by_upper_on_equal_lower = + KeyRange ((1 :: Integer) +=+ 5) < KeyRange (1 +=+ 10) + +prop_key_lower_bounds_by_value :: Bool +prop_key_lower_bounds_by_value = + KeyRange (lbi (1 :: Integer)) < KeyRange (lbi 2) + +prop_key_upper_bounds_by_value :: Bool +prop_key_upper_bounds_by_value = + KeyRange (ubi (1 :: Integer)) < KeyRange (ubi 2) + +prop_key_infinite_eq_infinite :: Bool +prop_key_infinite_eq_infinite = + compare (KeyRange (inf :: Range Integer)) (KeyRange inf) == 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 (ubi (0 :: Integer)) < SortedRange (lbi 0) + +prop_sorted_infinite_before_lower :: Bool +prop_sorted_infinite_before_lower = + SortedRange (inf :: Range Integer) < SortedRange (lbi 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 ((1 :: Integer) +=+ 10) < SortedRange (2 +=+ 10) + +-- When lower bounds are equal, tiebreak by upper bound (smaller upper = comes first) +prop_sorted_tiebreak_by_upper :: Bool +prop_sorted_tiebreak_by_upper = + SortedRange ((1 :: Integer) +=+ 5) < SortedRange (1 +=+ 10) + +-- InfiniteRange and UpperBoundRange both start at -∞; +-- InfiniteRange ends at +∞ so it sorts after a finite UpperBoundRange +prop_sorted_upper_before_infinite :: Bool +prop_sorted_upper_before_infinite = + SortedRange (ubi (0 :: Integer)) < SortedRange (inf :: Range Integer) + +-- The canonical display order: UpperBoundRange, SpanRange, LowerBoundRange +prop_sorted_display_order :: Bool +prop_sorted_display_order = + sortOn SortedRange [lbi 10, (1 :: Integer) +=+ 5, ube 0] + == [ube 0, 1 +=+ 5, lbi 10] + +-- 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,190 @@ +module Test.RangeParser + ( rangeParserTestCases + ) where + +import Test.Framework (Test, testGroup) +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 + +import Data.Range +import Data.Range.Parser + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +shouldParse :: String -> [Range Integer] -> Bool +shouldParse input expected = case parseRanges input of + Right result -> result == expected + Left _ -> False + +shouldFail :: String -> Bool +shouldFail input = case (parseRanges input :: Either ParseError [Range Integer]) of + Left _ -> True + Right _ -> False + +-- --------------------------------------------------------------------------- +-- Haddock example tests +-- --------------------------------------------------------------------------- + +-- The example from the module documentation: +-- >>> parseRanges "-5,8-10,13-15,20-" :: Either ParseError [Range Integer] +-- Right [UpperBoundRange 5,SpanRange 8 10,SpanRange 13 15,LowerBoundRange 20] +prop_haddock_example :: Bool +prop_haddock_example = shouldParse "-5,8-10,13-15,20-" + [ UpperBoundRange (Bound 5 Inclusive) + , 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] + +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 [Range Integer]) of + Right [] -> True + _ -> False + +-- The parser uses sepBy which returns [] on no matches, +-- so non-range input like "abc" or "-" parses as Right []. +-- This is a known limitation of the current parser design. +prop_non_range_input_parses_empty :: Bool +prop_non_range_input_parses_empty = + case (parseRanges "abc" :: Either ParseError [Range Integer]) of + Right [] -> True + _ -> False + +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 + ] + +-- --------------------------------------------------------------------------- +-- Custom parser args +-- --------------------------------------------------------------------------- + +prop_custom_separators :: Bool +prop_custom_separators = + let args = defaultArgs { unionSeparator = ";", rangeSeparator = ".." } + result = customParseRanges args "1..5;10" :: Either ParseError [Range Integer] + in case result of + Right ranges -> ranges == + [ 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_custom + ] diff --git a/range.cabal b/range.cabal --- a/range.cabal +++ b/range.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.1.0 +version: 0.3.2.0 -- A short (one-line) description of the package. synopsis: An efficient and versatile range library. @@ -62,6 +62,7 @@ -- Modules exported by the library. exposed-modules: Data.Range , Data.Ranges + , Data.Range.Ord , Data.Range.Parser , Data.Range.Algebra @@ -90,6 +91,10 @@ type: exitcode-stdio-1.0 main-is: Test/Range.hs other-modules: Test.RangeMerge + , Test.RangeLaws + , Test.RangeParser + , Test.RangeOrd + , Test.Generators build-depends: base >= 4.5 && < 5 , Cabal >= 1.14 , QuickCheck >= 2.4.0.1 && < 3 @@ -98,6 +103,8 @@ , random >= 1.0 , free >= 4.12 , deepseq >= 1.4 && < 2 + , parsec >= 3 && < 4 + , containers >= 0.5 && < 1 , range default-language: Haskell2010 ghc-options: -rtsopts -Wall -fno-enable-rewrite-rules