msakai / data-interval / 80

Committed 30 Aug 2025 08:23PM UTC coverage: 86.789% (+0.09%) from 86.702%

Build # 80

Build Type

push

github

Committed by

Bodigrim

Commit Message

Fix warnings

Run Details

1 of 4 new or added lines in 4 files covered. (25.0%)

87 existing lines in 4 files now uncovered.

992 of 1143 relevant lines covered (86.79%)

0.87 hits per line

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

88.62

/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
  , empty
  ) 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)

-- | 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 #-}

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	, empty
13	) where
14
15	import Control.DeepSeq
16	import Data.Data
17	import Data.ExtendedReal
18	import Data.Hashable
19	import Data.Int
20	import Foreign.Marshal.Array
21	import Foreign.Ptr
22	import Foreign.Storable
23	import GHC.Generics (Generic)
24
25	-- \| Boundary of an interval may be
26	-- open (excluding an endpoint) or closed (including an endpoint).
27	--
28	-- @since 2.0.0
29	data Boundary
30	= Open
31	\| Closed
NEW 32	deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data)	×
33
34	instance NFData Boundary
35
36	instance Hashable Boundary
37
38	-- \| The intervals (/i.e./ connected and convex subsets) over a type @r@.
39	data Interval r
40	= Whole
41	\| Empty
42	\| Point !r
43	\| LessThan !r
44	\| LessOrEqual !r
45	\| GreaterThan !r
46	\| GreaterOrEqual !r
47	-- For constructors below
48	-- the first argument is strictly less than the second one
49	\| BothClosed !r !r
50	\| LeftOpen !r !r
51	\| RightOpen !r !r
52	\| BothOpen !r !r
53	deriving
54	( Eq	1✔
55	, Ord	×
56	-- ^ Note that this Ord is derived and not semantically meaningful.
57	-- The primary intended use case is to allow using 'Interval'
58	-- in maps and sets that require ordering.
59	)
60
61	peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r)
62	peekInterval tagM x y = do	1✔
63	tag <- tagM	1✔
64	case tag of	1✔
65	0 -> pure Whole	1✔
66	1 -> pure Empty	1✔
67	2 -> Point <$> x	1✔
68	3 -> LessThan <$> x	1✔
69	4 -> LessOrEqual <$> x	1✔
70	5 -> GreaterThan <$> x	1✔
71	6 -> GreaterOrEqual <$> x	1✔
72	7 -> wrap BothClosed <$> x <*> y	1✔
73	8 -> wrap LeftOpen <$> x <*> y	1✔
74	9 -> wrap RightOpen <$> x <*> y	1✔
75	_ -> wrap BothOpen <$> x <*> y	1✔
76
77	-- \| Enforce the internal invariant
78	-- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'.
79	wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r
80	wrap f x y	1✔
81	\| x < y = f x y	×
82	\| otherwise = Empty	×
83
84	pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m ()
85	pokeInterval tag actX actY = \case	1✔
86	Whole -> tag (0 :: Int8)	1✔
87	Empty -> tag (1 :: Int8)	1✔
88	Point x -> tag (2 :: Int8) *> actX x	1✔
89	LessThan x -> tag (3 :: Int8) *> actX x	1✔
90	LessOrEqual x -> tag (4 :: Int8) *> actX x	1✔
91	GreaterThan x -> tag (5 :: Int8) *> actX x	1✔
92	GreaterOrEqual x -> tag (6 :: Int8) *> actX x	1✔
93	BothClosed x y -> tag (7 :: Int8) > actX x > actY y	1✔
94	LeftOpen x y -> tag (8 :: Int8) > actX x > actY y	1✔
95	RightOpen x y -> tag (9 :: Int8) > actX x > actY y	1✔
96	BothOpen x y -> tag (10 :: Int8) > actX x > actY y	1✔
97
98	instance (Storable r, Ord r) => Storable (Interval r) where
99	sizeOf _ = 3 * sizeOf (undefined :: r)	×
100	alignment _ = alignment (undefined :: r)	×
101	peek ptr = peekInterval	1✔
102	(peek $ castPtr ptr)	1✔
103	(peek $ castPtr ptr `advancePtr` 1)	1✔
104	(peek $ castPtr ptr `advancePtr` 2)	1✔
105	poke ptr = pokeInterval	1✔
106	(poke $ castPtr ptr)	1✔
107	(poke $ castPtr ptr `advancePtr` 1)	1✔
108	(poke $ castPtr ptr `advancePtr` 2)	1✔
109
110	-- \| Lower endpoint (/i.e./ greatest lower bound) of the interval,
111	-- together with 'Boundary' information.
112	-- The result is convenient to use as an argument for 'interval'.
113	lowerBound' :: Interval r -> (Extended r, Boundary)
114	lowerBound' = \case	1✔
115	Whole -> (NegInf, Open)	1✔
116	Empty -> (PosInf, Open)	1✔
117	Point r -> (Finite r, Closed)	1✔
118	LessThan{} -> (NegInf, Open)	1✔
119	LessOrEqual{} -> (NegInf, Open)	1✔
120	GreaterThan r -> (Finite r, Open)	1✔
121	GreaterOrEqual r -> (Finite r, Closed)	1✔
122	BothClosed p _ -> (Finite p, Closed)	1✔
123	LeftOpen p _ -> (Finite p, Open)	1✔
124	RightOpen p _ -> (Finite p, Closed)	1✔
125	BothOpen p _ -> (Finite p, Open)	1✔
126
127	-- \| Upper endpoint (/i.e./ least upper bound) of the interval,
128	-- together with 'Boundary' information.
129	-- The result is convenient to use as an argument for 'interval'.
130	upperBound' :: Interval r -> (Extended r, Boundary)
131	upperBound' = \case	1✔
132	Whole -> (PosInf, Open)	1✔
133	Empty -> (NegInf, Open)	1✔
134	Point r -> (Finite r, Closed)	1✔
135	LessThan r -> (Finite r, Open)	1✔
136	LessOrEqual r -> (Finite r, Closed)	1✔
137	GreaterThan{} -> (PosInf, Open)	1✔
138	GreaterOrEqual{} -> (PosInf, Open)	1✔
139	BothClosed _ q -> (Finite q, Closed)	1✔
140	LeftOpen _ q -> (Finite q, Closed)	1✔
141	RightOpen _ q -> (Finite q, Open)	1✔
142	BothOpen _ q -> (Finite q, Open)	1✔
143
144	type role Interval nominal
145
146	instance (Ord r, Data r) => Data (Interval r) where
147	gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x	1✔
148	toConstr _ = intervalConstr	×
149	gunfold k z c = case constrIndex c of	×
150	1 -> k (k (z interval))	×
151	_ -> error "gunfold"	×
152	dataTypeOf _ = intervalDataType	×
153	dataCast1 f = gcast1 f	×
154
155	intervalConstr :: Constr
156	intervalConstr = mkConstr intervalDataType "interval" [] Prefix	×
157
158	intervalDataType :: DataType
159	intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr]	×
160
161	instance NFData r => NFData (Interval r) where
162	rnf = \case	1✔
163	Whole -> ()	1✔
164	Empty -> ()	1✔
165	Point r -> rnf r	1✔
166	LessThan r -> rnf r	1✔
167	LessOrEqual r -> rnf r	1✔
168	GreaterThan r -> rnf r	1✔
169	GreaterOrEqual r -> rnf r	1✔
170	BothClosed p q -> rnf p `seq` rnf q	1✔
171	LeftOpen p q -> rnf p `seq` rnf q	1✔
172	RightOpen p q -> rnf p `seq` rnf q	1✔
173	BothOpen p q -> rnf p `seq` rnf q	1✔
174
175	instance Hashable r => Hashable (Interval r) where
176	hashWithSalt s = \case	1✔
177	Whole -> s `hashWithSalt` (1 :: Int)	1✔
178	Empty -> s `hashWithSalt` (2 :: Int)	1✔
179	Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r	1✔
180	LessThan r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r	1✔
181	LessOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r	1✔
182	GreaterThan r -> s `hashWithSalt` (6 :: Int) `hashWithSalt` r	1✔
183	GreaterOrEqual r -> s `hashWithSalt` (7 :: Int) `hashWithSalt` r	1✔
184	BothClosed p q -> s `hashWithSalt` (8 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
185	LeftOpen p q -> s `hashWithSalt` (9 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
186	RightOpen p q -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
187	BothOpen p q -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
188
189	-- \| empty (contradicting) interval
190	empty :: Ord r => Interval r
191	empty = Empty	1✔
192
193	-- \| smart constructor for 'Interval'
194	interval
195	:: (Ord r)
196	=> (Extended r, Boundary) -- ^ lower bound and whether it is included
197	-> (Extended r, Boundary) -- ^ upper bound and whether it is included
198	-> Interval r
199	interval = \case	1✔
200	(NegInf, _) -> \case	1✔
201	(NegInf, _) -> Empty	1✔
202	(Finite r, Open) -> LessThan r	1✔
203	(Finite r, Closed) -> LessOrEqual r	1✔
204	(PosInf, _) -> Whole	1✔
205	(Finite p, Open) -> \case	1✔
206	(NegInf, _) -> Empty	1✔
207	(Finite q, Open)
208	\| p < q -> BothOpen p q	1✔
209	\| otherwise -> Empty	1✔
210	(Finite q, Closed)
211	\| p < q -> LeftOpen p q	1✔
212	\| otherwise -> Empty	1✔
213	(PosInf, _) -> GreaterThan p	1✔
214	(Finite p, Closed) -> \case	1✔
215	(NegInf, _) -> Empty	1✔
216	(Finite q, Open)
217	\| p < q -> RightOpen p q	1✔
218	\| otherwise -> Empty	1✔
219	(Finite q, Closed) -> case p `compare` q of	1✔
220	LT -> BothClosed p q	1✔
221	EQ -> Point p	1✔
222	GT -> Empty	1✔
223	(PosInf, _) -> GreaterOrEqual p	1✔
224	(PosInf, _) -> const Empty	1✔
225	{-# INLINE interval #-}

msakai / data-interval / 80

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