msakai / data-interval / 104

Committed 03 Feb 2026 10:03PM UTC coverage: 87.261% (+0.2%) from 87.081%

Build # 104

Build Type

push

github

Committed by

Bodigrim

Commit Message

Add fromUnorderedBounds constructor

Run Details

30 of 33 new or added lines in 1 file covered. (90.91%)

2 existing lines in 2 files now uncovered.

1096 of 1256 relevant lines covered (87.26%)

0.87 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

90.05

/src/Data/Interval/Internal.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE RoleAnnotations #-}

module Data.Interval.Internal
  ( Boundary(..)
  , Interval
  , lowerBound'
  , upperBound'
  , interval
  , fromUnorderedBounds
  , empty
  , restrictMapKeysToInterval
  , withoutMapKeysFromInterval
  , intersectionSetAndInterval
  , differenceSetAndInterval
  ) where

import Control.DeepSeq
import Data.Data
import Data.ExtendedReal
import Data.Hashable
import Data.Int
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics (Generic)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)

-- | Boundary of an interval may be
-- open (excluding an endpoint) or closed (including an endpoint).
--
-- @since 2.0.0
data Boundary
  = Open
  | Closed
  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data)

instance NFData Boundary

instance Hashable Boundary

-- | The intervals (/i.e./ connected and convex subsets) over a type @r@.
data Interval r
  = Whole
  | Empty
  | Point !r
  | LessThan !r
  | LessOrEqual !r
  | GreaterThan !r
  | GreaterOrEqual !r
  -- For constructors below
  -- the first argument is strictly less than the second one
  | BothClosed !r !r
  | LeftOpen !r !r
  | RightOpen !r !r
  | BothOpen !r !r
  deriving
    ( Eq
    , Ord
      -- ^ Note that this Ord is derived and not semantically meaningful.
      -- The primary intended use case is to allow using 'Interval'
      -- in maps and sets that require ordering.
    )

peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r)
peekInterval tagM x y = do
  tag <- tagM
  case tag of
    0 -> pure Whole
    1 -> pure Empty
    2 -> Point           <$> x
    3 -> LessThan        <$> x
    4 -> LessOrEqual     <$> x
    5 -> GreaterThan     <$> x
    6 -> GreaterOrEqual  <$> x
    7 -> wrap BothClosed <$> x <*> y
    8 -> wrap LeftOpen   <$> x <*> y
    9 -> wrap RightOpen  <$> x <*> y
    _ -> wrap BothOpen   <$> x <*> y

-- | Enforce the internal invariant
-- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'.
wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r
wrap f x y
  | x < y = f x y
  | otherwise = Empty

pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m ()
pokeInterval tag actX actY = \case
  Whole            -> tag (0 :: Int8)
  Empty            -> tag (1 :: Int8)
  Point          x -> tag (2 :: Int8) *> actX x
  LessThan       x -> tag (3 :: Int8) *> actX x
  LessOrEqual    x -> tag (4 :: Int8) *> actX x
  GreaterThan    x -> tag (5 :: Int8) *> actX x
  GreaterOrEqual x -> tag (6 :: Int8) *> actX x
  BothClosed   x y -> tag (7 :: Int8) *> actX x *> actY y
  LeftOpen     x y -> tag (8 :: Int8) *> actX x *> actY y
  RightOpen    x y -> tag (9 :: Int8) *> actX x *> actY y
  BothOpen     x y -> tag (10 :: Int8) *> actX x *> actY y

instance (Storable r, Ord r) => Storable (Interval r) where
  sizeOf _ = 3 * sizeOf (undefined :: r)
  alignment _ = alignment (undefined :: r)
  peek ptr = peekInterval
    (peek $ castPtr ptr)
    (peek $ castPtr ptr `advancePtr` 1)
    (peek $ castPtr ptr `advancePtr` 2)
  poke ptr = pokeInterval
    (poke $ castPtr ptr)
    (poke $ castPtr ptr `advancePtr` 1)
    (poke $ castPtr ptr `advancePtr` 2)

-- | Lower endpoint (/i.e./ greatest lower bound) of the interval,
-- together with 'Boundary' information.
-- The result is convenient to use as an argument for 'interval'.
lowerBound' :: Interval r -> (Extended r, Boundary)
lowerBound' = \case
  Whole            -> (NegInf,   Open)
  Empty            -> (PosInf,   Open)
  Point r          -> (Finite r, Closed)
  LessThan{}       -> (NegInf,   Open)
  LessOrEqual{}    -> (NegInf,   Open)
  GreaterThan r    -> (Finite r, Open)
  GreaterOrEqual r -> (Finite r, Closed)
  BothClosed p _   -> (Finite p, Closed)
  LeftOpen p _     -> (Finite p, Open)
  RightOpen p _    -> (Finite p, Closed)
  BothOpen p _     -> (Finite p, Open)

-- | Upper endpoint (/i.e./ least upper bound) of the interval,
-- together with 'Boundary' information.
-- The result is convenient to use as an argument for 'interval'.
upperBound' :: Interval r -> (Extended r, Boundary)
upperBound' = \case
  Whole            -> (PosInf,   Open)
  Empty            -> (NegInf,   Open)
  Point r          -> (Finite r, Closed)
  LessThan r       -> (Finite r, Open)
  LessOrEqual r    -> (Finite r, Closed)
  GreaterThan{}    -> (PosInf,   Open)
  GreaterOrEqual{} -> (PosInf,   Open)
  BothClosed _ q   -> (Finite q, Closed)
  LeftOpen _ q     -> (Finite q, Closed)
  RightOpen _ q    -> (Finite q, Open)
  BothOpen _ q     -> (Finite q, Open)

type role Interval nominal

instance (Ord r, Data r) => Data (Interval r) where
  gfoldl k z x   = z interval `k` lowerBound' x `k` upperBound' x
  toConstr _     = intervalConstr
  gunfold k z c  = case constrIndex c of
    1 -> k (k (z interval))
    _ -> error "gunfold"
  dataTypeOf _   = intervalDataType
  dataCast1 f    = gcast1 f

intervalConstr :: Constr
intervalConstr = mkConstr intervalDataType "interval" [] Prefix

intervalDataType :: DataType
intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr]

instance NFData r => NFData (Interval r) where
  rnf = \case
    Whole            -> ()
    Empty            -> ()
    Point r          -> rnf r
    LessThan r       -> rnf r
    LessOrEqual r    -> rnf r
    GreaterThan r    -> rnf r
    GreaterOrEqual r -> rnf r
    BothClosed p q   -> rnf p `seq` rnf q
    LeftOpen p q     -> rnf p `seq` rnf q
    RightOpen p q    -> rnf p `seq` rnf q
    BothOpen p q     -> rnf p `seq` rnf q

instance Hashable r => Hashable (Interval r) where
  hashWithSalt s = \case
    Whole            -> s `hashWithSalt`  (1 :: Int)
    Empty            -> s `hashWithSalt`  (2 :: Int)
    Point r          -> s `hashWithSalt`  (3 :: Int) `hashWithSalt` r
    LessThan r       -> s `hashWithSalt`  (4 :: Int) `hashWithSalt` r
    LessOrEqual r    -> s `hashWithSalt`  (5 :: Int) `hashWithSalt` r
    GreaterThan r    -> s `hashWithSalt`  (6 :: Int) `hashWithSalt` r
    GreaterOrEqual r -> s `hashWithSalt`  (7 :: Int) `hashWithSalt` r
    BothClosed p q   -> s `hashWithSalt`  (8 :: Int) `hashWithSalt` p `hashWithSalt` q
    LeftOpen p q     -> s `hashWithSalt`  (9 :: Int) `hashWithSalt` p `hashWithSalt` q
    RightOpen p q    -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q
    BothOpen p q     -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q

-- | empty (contradicting) interval
empty :: Ord r => Interval r
empty = Empty

-- | smart constructor for 'Interval'
interval
  :: (Ord r)
  => (Extended r, Boundary) -- ^ lower bound and whether it is included
  -> (Extended r, Boundary) -- ^ upper bound and whether it is included
  -> Interval r
interval = \case
  (NegInf, _) -> \case
    (NegInf, _) -> Empty
    (Finite r, Open) -> LessThan r
    (Finite r, Closed) -> LessOrEqual r
    (PosInf, _) -> Whole
  (Finite p, Open) -> \case
    (NegInf, _) -> Empty
    (Finite q, Open)
      | p < q -> BothOpen p q
      | otherwise -> Empty
    (Finite q, Closed)
      | p < q -> LeftOpen p q
      | otherwise -> Empty
    (PosInf, _) -> GreaterThan p
  (Finite p, Closed) -> \case
    (NegInf, _) -> Empty
    (Finite q, Open)
      | p < q -> RightOpen p q
      | otherwise -> Empty
    (Finite q, Closed) -> case p `compare` q of
      LT -> BothClosed p q
      EQ -> Point p
      GT -> Empty
    (PosInf, _) -> GreaterOrEqual p
  (PosInf, _) -> const Empty
{-# INLINE interval #-}

-- | Same as 'interval' but swaps the lower and upper bounds when given in
-- reverse order.
fromUnorderedBounds
  :: (Ord r)
  => (Extended r, Boundary) -- ^ lower or upper bound and whether it is included
  -> (Extended r, Boundary) -- ^ upper or upper bound and whether it is included
  -> Interval r
fromUnorderedBounds = \case
  (NegInf, _) -> \case
    (NegInf, _) -> Empty
    (Finite r, Open) -> LessThan r
    (Finite r, Closed) -> LessOrEqual r
    (PosInf, _) -> Whole
  (Finite p, Open) -> \case
    (NegInf, _) -> LessThan p
    (Finite q, Open) -> case p `compare` q of
      LT -> BothOpen p q
      GT -> BothOpen q p
      EQ -> Empty
    (Finite q, Closed) -> case p `compare` q of
      LT -> LeftOpen p q
      GT -> RightOpen q p
      EQ -> Empty
    (PosInf, _) -> GreaterThan p
  (Finite p, Closed) -> \case
    (NegInf, _) -> LessOrEqual p
    (Finite q, Open) -> case p `compare` q of
      LT -> RightOpen p q
      GT -> LeftOpen q p
      EQ -> Empty
    (Finite q, Closed) -> case p `compare` q of
      LT -> BothClosed p q
      EQ -> Point p
      GT -> BothClosed q p
    (PosInf, _) -> GreaterOrEqual p
  (PosInf, _) -> \case
    (NegInf, _) -> Whole
    (Finite r, Open) -> GreaterThan r
    (Finite r, Closed) -> GreaterOrEqual r
    (PosInf, _) -> Empty
{-# INLINE fromUnorderedBounds #-}

------------------------------------------------------------------------------

-- | \(O(\log n)\). Restrict a 'Map' to the keys contained in a given
-- 'Interval'.
--
-- >>> restrictMapKeysToInterval m i == filterKeys (\k -> Interval.member k i) m
--
-- [Usage:]
--
-- >>> m = Map.fromList [(-2.5,0),(3.1,1),(5,2), (8.5,3)] :: Map Rational Int
-- >>> restrictMapKeysToInterval m (3 <=..< 8.5)
-- fromList [(31 % 10,1),(5 % 1,2)]
--
-- [Performance:]
-- This outperforms 'filterKeys' which is \(O(n)\).
--
restrictMapKeysToInterval :: Ord k => Map k a -> Interval k -> Map k a
restrictMapKeysToInterval m = \case
  Whole -> m
  Empty -> Map.empty
  Point k -> maybe Map.empty (Map.singleton k) (Map.lookup k m)
  LessThan k -> Map.takeWhileAntitone (< k) m
  LessOrEqual k -> Map.takeWhileAntitone (<= k) m
  GreaterThan k -> Map.dropWhileAntitone (<= k) m
  GreaterOrEqual k -> Map.dropWhileAntitone (< k) m
  BothClosed lk uk ->
    Map.takeWhileAntitone (<= uk) $ Map.dropWhileAntitone (< lk) m
  LeftOpen lk uk ->
    Map.takeWhileAntitone (<= uk) $ Map.dropWhileAntitone (<= lk) m
  RightOpen lk uk ->
    Map.takeWhileAntitone (< uk) $ Map.dropWhileAntitone (< lk) m
  BothOpen lk uk ->
    Map.takeWhileAntitone (< uk) $ Map.dropWhileAntitone (<= lk) m
{-# INLINE restrictMapKeysToInterval #-}

-- | \(O(n)\). Delete keys contained in a given 'Interval' from a 'Map'.
--
-- >>> withoutMapKeysFromInterval i m == filterKeys (\k -> Interval.notMember k i) m
--
-- [Usage:]
--
-- >>> m = Map.fromList [(-2.5,0),(3.1,1),(5,2), (8.5,3)] :: Map Rational Int
-- >>> withoutMapKeysFromInterval (3 <=..< 8.5) m
-- fromList [((-5) % 2,0),(17 % 2,3)]
--
-- [Performance:] In practice, this outperforms 'filterKeys'.
--
withoutMapKeysFromInterval :: Ord k => Interval k -> Map k a -> Map k a
withoutMapKeysFromInterval i m = case i of
  Whole -> Map.empty
  Empty -> m
  Point k -> Map.delete k m
  LessThan k -> restrictMapKeysToInterval m (GreaterOrEqual k)
  LessOrEqual k -> restrictMapKeysToInterval m (GreaterThan k)
  GreaterThan k -> restrictMapKeysToInterval m (LessOrEqual k)
  GreaterOrEqual k -> restrictMapKeysToInterval m (LessThan k)
  BothClosed lk uk -> let (lt,_,gt) = Map.splitLookup uk m in
    restrictMapKeysToInterval lt (LessThan lk) `Map.union` gt
  LeftOpen lk uk -> let (lt,_,gt) = Map.splitLookup uk m in
    restrictMapKeysToInterval lt (LessOrEqual lk) `Map.union` gt
  RightOpen lk uk -> let (lt,_,gt) = Map.splitLookup lk m in
    lt `Map.union` restrictMapKeysToInterval gt (GreaterOrEqual uk)
  BothOpen lk uk ->
    restrictMapKeysToInterval m (LessOrEqual lk)
    `Map.union` restrictMapKeysToInterval m (GreaterOrEqual uk)
{-# INLINE withoutMapKeysFromInterval #-}

------------------------------------------------------------------------------

-- | \(O(\log n)\). Restrict a 'Set' to the keys contained in a given
-- 'Interval'.
--
-- >>> intersectionSetAndInterval s i == Set.filter (\k -> Interval.member k i) s
--
-- [Usage:]
--
-- >>> s = Set.fromList [-2.5, 3.1, 5 , 8.5] :: Set Rational
-- >>> intersectionSetAndInterval s (3 <=..< 8.5)
-- fromList [31 % 10,5 % 1]
--
-- [Performance:] This outperforms 'Set.filter' which is \(O(n)\).
--
intersectionSetAndInterval :: Ord k => Set k -> Interval k -> Set k
intersectionSetAndInterval s = \case
  Whole -> s
  Empty -> Set.empty
  Point k -> if Set.member k s then Set.singleton k else Set.empty
  LessThan k -> Set.takeWhileAntitone (< k) s
  LessOrEqual k -> Set.takeWhileAntitone (<= k) s
  GreaterThan k -> Set.dropWhileAntitone (<= k) s
  GreaterOrEqual k -> Set.dropWhileAntitone (< k) s
  BothClosed lk uk ->
    Set.takeWhileAntitone (<= uk) $ Set.dropWhileAntitone (< lk) s
  LeftOpen lk uk ->
    Set.takeWhileAntitone (<= uk) $ Set.dropWhileAntitone (<= lk) s
  RightOpen lk uk ->
    Set.takeWhileAntitone (< uk) $ Set.dropWhileAntitone (< lk) s
  BothOpen lk uk ->
    Set.takeWhileAntitone (< uk) $ Set.dropWhileAntitone (<= lk) s
{-# INLINE intersectionSetAndInterval #-}

-- | \(O(n)\). Delete keys contained in a given 'Interval' from a 'Set'.
--
-- >>> differenceSetAndInterval i s == Set.filter (\k -> Interval.notMember k i) s
--
-- [Usage:]
--
-- >>> s = Set.fromList [-2.5, 3.1, 5 , 8.5] :: Set Rational
-- >>> differenceSetAndInterval s (3 <=..< 8.5)
-- fromList [(-5) % 2,17 % 2]
--
-- [Performance:] In practice, this outperforms 'Set.filter'.
--
differenceSetAndInterval :: Ord k => Set k -> Interval k -> Set k
differenceSetAndInterval s i = case i of
  Whole -> Set.empty
  Empty -> s
  Point k -> Set.delete k s
  LessThan k -> intersectionSetAndInterval s (GreaterOrEqual k)
  LessOrEqual k -> intersectionSetAndInterval s (GreaterThan k)
  GreaterThan k -> intersectionSetAndInterval s (LessOrEqual k)
  GreaterOrEqual k -> intersectionSetAndInterval s (LessThan k)
  BothClosed lk uk -> let (lt,_,gt) = Set.splitMember uk s in
    Set.takeWhileAntitone (< lk) lt `Set.union` gt
  LeftOpen lk uk -> let (lt,_,gt) = Set.splitMember uk s in
    Set.takeWhileAntitone (<= lk) lt `Set.union` gt
  RightOpen lk uk -> let (lt,_,gt) = Set.splitMember lk s in
    lt `Set.union` Set.dropWhileAntitone (< uk) gt
  BothOpen lk uk ->
    Set.takeWhileAntitone (<= lk) s `Set.union` Set.dropWhileAntitone (< uk) s
{-# INLINE differenceSetAndInterval #-}

1	{-# OPTIONS_GHC -Wall #-}
2	{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables #-}
3	{-# LANGUAGE Safe #-}
4	{-# LANGUAGE RoleAnnotations #-}
5
6	module Data.Interval.Internal
7	( Boundary(..)
8	, Interval
9	, lowerBound'
10	, upperBound'
11	, interval
12	, fromUnorderedBounds
13	, empty
14	, restrictMapKeysToInterval
15	, withoutMapKeysFromInterval
16	, intersectionSetAndInterval
17	, differenceSetAndInterval
18	) where
19
20	import Control.DeepSeq
21	import Data.Data
22	import Data.ExtendedReal
23	import Data.Hashable
24	import Data.Int
25	import Foreign.Marshal.Array
26	import Foreign.Ptr
27	import Foreign.Storable
28	import GHC.Generics (Generic)
29	import qualified Data.Map as Map
30	import Data.Map (Map)
31	import qualified Data.Set as Set
32	import Data.Set (Set)
33
34	-- \| Boundary of an interval may be
35	-- open (excluding an endpoint) or closed (including an endpoint).
36	--
37	-- @since 2.0.0
38	data Boundary
39	= Open
40	\| Closed
41	deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data)	×
42
43	instance NFData Boundary
44
45	instance Hashable Boundary
46
47	-- \| The intervals (/i.e./ connected and convex subsets) over a type @r@.
48	data Interval r
49	= Whole
50	\| Empty
51	\| Point !r
52	\| LessThan !r
53	\| LessOrEqual !r
54	\| GreaterThan !r
55	\| GreaterOrEqual !r
56	-- For constructors below
57	-- the first argument is strictly less than the second one
58	\| BothClosed !r !r
59	\| LeftOpen !r !r
60	\| RightOpen !r !r
61	\| BothOpen !r !r
62	deriving
63	( Eq	1✔
64	, Ord	×
65	-- ^ Note that this Ord is derived and not semantically meaningful.
66	-- The primary intended use case is to allow using 'Interval'
67	-- in maps and sets that require ordering.
68	)
69
70	peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r)
71	peekInterval tagM x y = do	1✔
72	tag <- tagM	1✔
73	case tag of	1✔
74	0 -> pure Whole	1✔
75	1 -> pure Empty	1✔
76	2 -> Point <$> x	1✔
77	3 -> LessThan <$> x	1✔
78	4 -> LessOrEqual <$> x	1✔
79	5 -> GreaterThan <$> x	1✔
80	6 -> GreaterOrEqual <$> x	1✔
81	7 -> wrap BothClosed <$> x <*> y	1✔
82	8 -> wrap LeftOpen <$> x <*> y	1✔
83	9 -> wrap RightOpen <$> x <*> y	1✔
84	_ -> wrap BothOpen <$> x <*> y	1✔
85
86	-- \| Enforce the internal invariant
87	-- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'.
88	wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r
89	wrap f x y	1✔
90	\| x < y = f x y	×
91	\| otherwise = Empty	×
92
93	pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m ()
94	pokeInterval tag actX actY = \case	1✔
95	Whole -> tag (0 :: Int8)	1✔
96	Empty -> tag (1 :: Int8)	1✔
97	Point x -> tag (2 :: Int8) *> actX x	1✔
98	LessThan x -> tag (3 :: Int8) *> actX x	1✔
99	LessOrEqual x -> tag (4 :: Int8) *> actX x	1✔
100	GreaterThan x -> tag (5 :: Int8) *> actX x	1✔
101	GreaterOrEqual x -> tag (6 :: Int8) *> actX x	1✔
102	BothClosed x y -> tag (7 :: Int8) > actX x > actY y	1✔
103	LeftOpen x y -> tag (8 :: Int8) > actX x > actY y	1✔
104	RightOpen x y -> tag (9 :: Int8) > actX x > actY y	1✔
105	BothOpen x y -> tag (10 :: Int8) > actX x > actY y	1✔
106
107	instance (Storable r, Ord r) => Storable (Interval r) where
108	sizeOf _ = 3 * sizeOf (undefined :: r)	×
109	alignment _ = alignment (undefined :: r)	×
110	peek ptr = peekInterval	1✔
111	(peek $ castPtr ptr)	1✔
112	(peek $ castPtr ptr `advancePtr` 1)	1✔
113	(peek $ castPtr ptr `advancePtr` 2)	1✔
114	poke ptr = pokeInterval	1✔
115	(poke $ castPtr ptr)	1✔
116	(poke $ castPtr ptr `advancePtr` 1)	1✔
117	(poke $ castPtr ptr `advancePtr` 2)	1✔
118
119	-- \| Lower endpoint (/i.e./ greatest lower bound) of the interval,
120	-- together with 'Boundary' information.
121	-- The result is convenient to use as an argument for 'interval'.
122	lowerBound' :: Interval r -> (Extended r, Boundary)
123	lowerBound' = \case	1✔
124	Whole -> (NegInf, Open)	1✔
125	Empty -> (PosInf, Open)	1✔
126	Point r -> (Finite r, Closed)	1✔
127	LessThan{} -> (NegInf, Open)	1✔
128	LessOrEqual{} -> (NegInf, Open)	1✔
129	GreaterThan r -> (Finite r, Open)	1✔
130	GreaterOrEqual r -> (Finite r, Closed)	1✔
131	BothClosed p _ -> (Finite p, Closed)	1✔
132	LeftOpen p _ -> (Finite p, Open)	1✔
133	RightOpen p _ -> (Finite p, Closed)	1✔
134	BothOpen p _ -> (Finite p, Open)	1✔
135
136	-- \| Upper endpoint (/i.e./ least upper bound) of the interval,
137	-- together with 'Boundary' information.
138	-- The result is convenient to use as an argument for 'interval'.
139	upperBound' :: Interval r -> (Extended r, Boundary)
140	upperBound' = \case	1✔
141	Whole -> (PosInf, Open)	1✔
142	Empty -> (NegInf, Open)	1✔
143	Point r -> (Finite r, Closed)	1✔
144	LessThan r -> (Finite r, Open)	1✔
145	LessOrEqual r -> (Finite r, Closed)	1✔
146	GreaterThan{} -> (PosInf, Open)	1✔
147	GreaterOrEqual{} -> (PosInf, Open)	1✔
148	BothClosed _ q -> (Finite q, Closed)	1✔
149	LeftOpen _ q -> (Finite q, Closed)	1✔
150	RightOpen _ q -> (Finite q, Open)	1✔
151	BothOpen _ q -> (Finite q, Open)	1✔
152
153	type role Interval nominal
154
155	instance (Ord r, Data r) => Data (Interval r) where
156	gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x	1✔
157	toConstr _ = intervalConstr	×
158	gunfold k z c = case constrIndex c of	×
159	1 -> k (k (z interval))	×
160	_ -> error "gunfold"	×
161	dataTypeOf _ = intervalDataType	×
162	dataCast1 f = gcast1 f	×
163
164	intervalConstr :: Constr
165	intervalConstr = mkConstr intervalDataType "interval" [] Prefix	×
166
167	intervalDataType :: DataType
168	intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr]	×
169
170	instance NFData r => NFData (Interval r) where
171	rnf = \case	1✔
172	Whole -> ()	1✔
173	Empty -> ()	1✔
174	Point r -> rnf r	1✔
175	LessThan r -> rnf r	1✔
176	LessOrEqual r -> rnf r	1✔
177	GreaterThan r -> rnf r	1✔
178	GreaterOrEqual r -> rnf r	1✔
179	BothClosed p q -> rnf p `seq` rnf q	1✔
180	LeftOpen p q -> rnf p `seq` rnf q	1✔
181	RightOpen p q -> rnf p `seq` rnf q	1✔
182	BothOpen p q -> rnf p `seq` rnf q	1✔
183
184	instance Hashable r => Hashable (Interval r) where
185	hashWithSalt s = \case	1✔
186	Whole -> s `hashWithSalt` (1 :: Int)	1✔
187	Empty -> s `hashWithSalt` (2 :: Int)	1✔
188	Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r	1✔
189	LessThan r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r	1✔
190	LessOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r	1✔
191	GreaterThan r -> s `hashWithSalt` (6 :: Int) `hashWithSalt` r	1✔
192	GreaterOrEqual r -> s `hashWithSalt` (7 :: Int) `hashWithSalt` r	1✔
193	BothClosed p q -> s `hashWithSalt` (8 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
194	LeftOpen p q -> s `hashWithSalt` (9 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
195	RightOpen p q -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
196	BothOpen p q -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
197
198	-- \| empty (contradicting) interval
199	empty :: Ord r => Interval r
200	empty = Empty	1✔
201
202	-- \| smart constructor for 'Interval'
203	interval
204	:: (Ord r)
205	=> (Extended r, Boundary) -- ^ lower bound and whether it is included
206	-> (Extended r, Boundary) -- ^ upper bound and whether it is included
207	-> Interval r
208	interval = \case	1✔
209	(NegInf, _) -> \case	1✔
210	(NegInf, _) -> Empty	1✔
211	(Finite r, Open) -> LessThan r	1✔
212	(Finite r, Closed) -> LessOrEqual r	1✔
213	(PosInf, _) -> Whole	1✔
214	(Finite p, Open) -> \case	1✔
215	(NegInf, _) -> Empty	1✔
216	(Finite q, Open)
217	\| p < q -> BothOpen p q	1✔
218	\| otherwise -> Empty	1✔
219	(Finite q, Closed)
220	\| p < q -> LeftOpen p q	1✔
221	\| otherwise -> Empty	1✔
222	(PosInf, _) -> GreaterThan p	1✔
223	(Finite p, Closed) -> \case	1✔
224	(NegInf, _) -> Empty	1✔
225	(Finite q, Open)
226	\| p < q -> RightOpen p q	1✔
227	\| otherwise -> Empty	1✔
228	(Finite q, Closed) -> case p `compare` q of	1✔
229	LT -> BothClosed p q	1✔
230	EQ -> Point p	1✔
231	GT -> Empty	1✔
232	(PosInf, _) -> GreaterOrEqual p	1✔
233	(PosInf, _) -> const Empty	1✔
234	{-# INLINE interval #-}
235
236	-- \| Same as 'interval' but swaps the lower and upper bounds when given in
237	-- reverse order.
238	fromUnorderedBounds
239	:: (Ord r)
240	=> (Extended r, Boundary) -- ^ lower or upper bound and whether it is included
241	-> (Extended r, Boundary) -- ^ upper or upper bound and whether it is included
242	-> Interval r
243	fromUnorderedBounds = \case	1✔
244	(NegInf, _) -> \case	1✔
245	(NegInf, _) -> Empty	1✔
246	(Finite r, Open) -> LessThan r	1✔
247	(Finite r, Closed) -> LessOrEqual r	1✔
248	(PosInf, _) -> Whole	1✔
249	(Finite p, Open) -> \case	1✔
250	(NegInf, _) -> LessThan p	1✔
251	(Finite q, Open) -> case p `compare` q of	1✔
252	LT -> BothOpen p q	1✔
253	GT -> BothOpen q p	1✔
NEW 254	EQ -> Empty	×
255	(Finite q, Closed) -> case p `compare` q of	1✔
256	LT -> LeftOpen p q	1✔
257	GT -> RightOpen q p	1✔
NEW 258	EQ -> Empty	×
259	(PosInf, _) -> GreaterThan p	1✔
260	(Finite p, Closed) -> \case	1✔
261	(NegInf, _) -> LessOrEqual p	1✔
262	(Finite q, Open) -> case p `compare` q of	1✔
263	LT -> RightOpen p q	1✔
264	GT -> LeftOpen q p	1✔
265	EQ -> Empty	1✔
266	(Finite q, Closed) -> case p `compare` q of	1✔
267	LT -> BothClosed p q	1✔
NEW 268	EQ -> Point p	×
269	GT -> BothClosed q p	1✔
270	(PosInf, _) -> GreaterOrEqual p	1✔
271	(PosInf, _) -> \case	1✔
272	(NegInf, _) -> Whole	1✔
273	(Finite r, Open) -> GreaterThan r	1✔
274	(Finite r, Closed) -> GreaterOrEqual r	1✔
275	(PosInf, _) -> Empty	1✔
276	{-# INLINE fromUnorderedBounds #-}
277
278	------------------------------------------------------------------------------
279
280	-- \| \(O(\log n)\). Restrict a 'Map' to the keys contained in a given
281	-- 'Interval'.
282	--
283	-- >>> restrictMapKeysToInterval m i == filterKeys (\k -> Interval.member k i) m
284	--
285	-- [Usage:]
286	--
287	-- >>> m = Map.fromList [(-2.5,0),(3.1,1),(5,2), (8.5,3)] :: Map Rational Int
288	-- >>> restrictMapKeysToInterval m (3 <=..< 8.5)
289	-- fromList [(31 % 10,1),(5 % 1,2)]
290	--
291	-- [Performance:]
292	-- This outperforms 'filterKeys' which is \(O(n)\).
293	--
294	restrictMapKeysToInterval :: Ord k => Map k a -> Interval k -> Map k a
295	restrictMapKeysToInterval m = \case	1✔
296	Whole -> m	1✔
297	Empty -> Map.empty	1✔
298	Point k -> maybe Map.empty (Map.singleton k) (Map.lookup k m)	×
299	LessThan k -> Map.takeWhileAntitone (< k) m	1✔
300	LessOrEqual k -> Map.takeWhileAntitone (<= k) m	1✔
301	GreaterThan k -> Map.dropWhileAntitone (<= k) m	1✔
302	GreaterOrEqual k -> Map.dropWhileAntitone (< k) m	1✔
303	BothClosed lk uk ->
304	Map.takeWhileAntitone (<= uk) $ Map.dropWhileAntitone (< lk) m	1✔
305	LeftOpen lk uk ->
306	Map.takeWhileAntitone (<= uk) $ Map.dropWhileAntitone (<= lk) m	1✔
307	RightOpen lk uk ->
308	Map.takeWhileAntitone (< uk) $ Map.dropWhileAntitone (< lk) m	1✔
309	BothOpen lk uk ->
310	Map.takeWhileAntitone (< uk) $ Map.dropWhileAntitone (<= lk) m	1✔
311	{-# INLINE restrictMapKeysToInterval #-}
312
313	-- \| \(O(n)\). Delete keys contained in a given 'Interval' from a 'Map'.
314	--
315	-- >>> withoutMapKeysFromInterval i m == filterKeys (\k -> Interval.notMember k i) m
316	--
317	-- [Usage:]
318	--
319	-- >>> m = Map.fromList [(-2.5,0),(3.1,1),(5,2), (8.5,3)] :: Map Rational Int
320	-- >>> withoutMapKeysFromInterval (3 <=..< 8.5) m
321	-- fromList [((-5) % 2,0),(17 % 2,3)]
322	--
323	-- [Performance:] In practice, this outperforms 'filterKeys'.
324	--
325	withoutMapKeysFromInterval :: Ord k => Interval k -> Map k a -> Map k a
326	withoutMapKeysFromInterval i m = case i of	1✔
327	Whole -> Map.empty	1✔
328	Empty -> m	1✔
UNCOV 329	Point k -> Map.delete k m	×
330	LessThan k -> restrictMapKeysToInterval m (GreaterOrEqual k)	1✔
331	LessOrEqual k -> restrictMapKeysToInterval m (GreaterThan k)	1✔
332	GreaterThan k -> restrictMapKeysToInterval m (LessOrEqual k)	1✔
333	GreaterOrEqual k -> restrictMapKeysToInterval m (LessThan k)	1✔
334	BothClosed lk uk -> let (lt,_,gt) = Map.splitLookup uk m in	1✔
335	restrictMapKeysToInterval lt (LessThan lk) `Map.union` gt	1✔
336	LeftOpen lk uk -> let (lt,_,gt) = Map.splitLookup uk m in	1✔
337	restrictMapKeysToInterval lt (LessOrEqual lk) `Map.union` gt	1✔
338	RightOpen lk uk -> let (lt,_,gt) = Map.splitLookup lk m in	1✔
339	lt `Map.union` restrictMapKeysToInterval gt (GreaterOrEqual uk)	1✔
340	BothOpen lk uk ->
341	restrictMapKeysToInterval m (LessOrEqual lk)	1✔
342	`Map.union` restrictMapKeysToInterval m (GreaterOrEqual uk)	1✔
343	{-# INLINE withoutMapKeysFromInterval #-}
344
345	------------------------------------------------------------------------------
346
347	-- \| \(O(\log n)\). Restrict a 'Set' to the keys contained in a given
348	-- 'Interval'.
349	--
350	-- >>> intersectionSetAndInterval s i == Set.filter (\k -> Interval.member k i) s
351	--
352	-- [Usage:]
353	--
354	-- >>> s = Set.fromList [-2.5, 3.1, 5 , 8.5] :: Set Rational
355	-- >>> intersectionSetAndInterval s (3 <=..< 8.5)
356	-- fromList [31 % 10,5 % 1]
357	--
358	-- [Performance:] This outperforms 'Set.filter' which is \(O(n)\).
359	--
360	intersectionSetAndInterval :: Ord k => Set k -> Interval k -> Set k
361	intersectionSetAndInterval s = \case	1✔
362	Whole -> s	1✔
363	Empty -> Set.empty	1✔
364	Point k -> if Set.member k s then Set.singleton k else Set.empty	×
365	LessThan k -> Set.takeWhileAntitone (< k) s	1✔
366	LessOrEqual k -> Set.takeWhileAntitone (<= k) s	1✔
367	GreaterThan k -> Set.dropWhileAntitone (<= k) s	1✔
368	GreaterOrEqual k -> Set.dropWhileAntitone (< k) s	1✔
369	BothClosed lk uk ->
370	Set.takeWhileAntitone (<= uk) $ Set.dropWhileAntitone (< lk) s	1✔
371	LeftOpen lk uk ->
372	Set.takeWhileAntitone (<= uk) $ Set.dropWhileAntitone (<= lk) s	1✔
373	RightOpen lk uk ->
374	Set.takeWhileAntitone (< uk) $ Set.dropWhileAntitone (< lk) s	1✔
375	BothOpen lk uk ->
376	Set.takeWhileAntitone (< uk) $ Set.dropWhileAntitone (<= lk) s	1✔
377	{-# INLINE intersectionSetAndInterval #-}
378
379	-- \| \(O(n)\). Delete keys contained in a given 'Interval' from a 'Set'.
380	--
381	-- >>> differenceSetAndInterval i s == Set.filter (\k -> Interval.notMember k i) s
382	--
383	-- [Usage:]
384	--
385	-- >>> s = Set.fromList [-2.5, 3.1, 5 , 8.5] :: Set Rational
386	-- >>> differenceSetAndInterval s (3 <=..< 8.5)
387	-- fromList [(-5) % 2,17 % 2]
388	--
389	-- [Performance:] In practice, this outperforms 'Set.filter'.
390	--
391	differenceSetAndInterval :: Ord k => Set k -> Interval k -> Set k
392	differenceSetAndInterval s i = case i of	1✔
393	Whole -> Set.empty	1✔
394	Empty -> s	1✔
395	Point k -> Set.delete k s	×
396	LessThan k -> intersectionSetAndInterval s (GreaterOrEqual k)	1✔
397	LessOrEqual k -> intersectionSetAndInterval s (GreaterThan k)	1✔
398	GreaterThan k -> intersectionSetAndInterval s (LessOrEqual k)	1✔
399	GreaterOrEqual k -> intersectionSetAndInterval s (LessThan k)	1✔
400	BothClosed lk uk -> let (lt,_,gt) = Set.splitMember uk s in	1✔
401	Set.takeWhileAntitone (< lk) lt `Set.union` gt	1✔
402	LeftOpen lk uk -> let (lt,_,gt) = Set.splitMember uk s in	1✔
403	Set.takeWhileAntitone (<= lk) lt `Set.union` gt	1✔
404	RightOpen lk uk -> let (lt,_,gt) = Set.splitMember lk s in	1✔
405	lt `Set.union` Set.dropWhileAntitone (< uk) gt	1✔
406	BothOpen lk uk ->
407	Set.takeWhileAntitone (<= lk) s `Set.union` Set.dropWhileAntitone (< uk) s	1✔
408	{-# INLINE differenceSetAndInterval #-}

msakai / data-interval / 104

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous