msakai / data-interval / 74

Committed 07 Jun 2025 02:12PM UTC coverage: 86.789% (-0.05%) from 86.837%

Build # 74

Build Type

push

github

Committed by

web-flow

Commit Message

Merge 0e36d5686 into 8f4ec0ead

Run Details

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, Typeable)

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.
    , Typeable
    )

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
32	deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Data, Typeable)	×
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	, Typeable
60	)
61
62	peekInterval :: (Applicative m, Monad m, Ord r) => m Int8 -> m r -> m r -> m (Interval r)
63	peekInterval tagM x y = do	1✔
64	tag <- tagM	1✔
65	case tag of	1✔
66	0 -> pure Whole	1✔
67	1 -> pure Empty	1✔
68	2 -> Point <$> x	1✔
69	3 -> LessThan <$> x	1✔
70	4 -> LessOrEqual <$> x	1✔
71	5 -> GreaterThan <$> x	1✔
72	6 -> GreaterOrEqual <$> x	1✔
73	7 -> wrap BothClosed <$> x <*> y	1✔
74	8 -> wrap LeftOpen <$> x <*> y	1✔
75	9 -> wrap RightOpen <$> x <*> y	1✔
76	_ -> wrap BothOpen <$> x <*> y	1✔
77
78	-- \| Enforce the internal invariant
79	-- of 'BothClosed' / 'LeftOpen' / 'RightOpen' / 'BothOpen'.
80	wrap :: Ord r => (r -> r -> Interval r) -> r -> r -> Interval r
81	wrap f x y	1✔
82	\| x < y = f x y	×
83	\| otherwise = Empty	×
84
85	pokeInterval :: Applicative m => (Int8 -> m ()) -> (r -> m ()) -> (r -> m ()) -> Interval r -> m ()
86	pokeInterval tag actX actY = \case	1✔
87	Whole -> tag (0 :: Int8)	1✔
88	Empty -> tag (1 :: Int8)	1✔
89	Point x -> tag (2 :: Int8) *> actX x	1✔
90	LessThan x -> tag (3 :: Int8) *> actX x	1✔
91	LessOrEqual x -> tag (4 :: Int8) *> actX x	1✔
92	GreaterThan x -> tag (5 :: Int8) *> actX x	1✔
93	GreaterOrEqual x -> tag (6 :: Int8) *> actX x	1✔
94	BothClosed x y -> tag (7 :: Int8) > actX x > actY y	1✔
95	LeftOpen x y -> tag (8 :: Int8) > actX x > actY y	1✔
96	RightOpen x y -> tag (9 :: Int8) > actX x > actY y	1✔
97	BothOpen x y -> tag (10 :: Int8) > actX x > actY y	1✔
98
99	instance (Storable r, Ord r) => Storable (Interval r) where
100	sizeOf _ = 3 * sizeOf (undefined :: r)	×
101	alignment _ = alignment (undefined :: r)	×
102	peek ptr = peekInterval	1✔
103	(peek $ castPtr ptr)	1✔
104	(peek $ castPtr ptr `advancePtr` 1)	1✔
105	(peek $ castPtr ptr `advancePtr` 2)	1✔
106	poke ptr = pokeInterval	1✔
107	(poke $ castPtr ptr)	1✔
108	(poke $ castPtr ptr `advancePtr` 1)	1✔
109	(poke $ castPtr ptr `advancePtr` 2)	1✔
110
111	-- \| Lower endpoint (/i.e./ greatest lower bound) of the interval,
112	-- together with 'Boundary' information.
113	-- The result is convenient to use as an argument for 'interval'.
114	lowerBound' :: Interval r -> (Extended r, Boundary)
115	lowerBound' = \case	1✔
116	Whole -> (NegInf, Open)	1✔
117	Empty -> (PosInf, Open)	1✔
118	Point r -> (Finite r, Closed)	1✔
119	LessThan{} -> (NegInf, Open)	1✔
120	LessOrEqual{} -> (NegInf, Open)	1✔
121	GreaterThan r -> (Finite r, Open)	1✔
122	GreaterOrEqual r -> (Finite r, Closed)	1✔
123	BothClosed p _ -> (Finite p, Closed)	1✔
124	LeftOpen p _ -> (Finite p, Open)	1✔
125	RightOpen p _ -> (Finite p, Closed)	1✔
126	BothOpen p _ -> (Finite p, Open)	1✔
127
128	-- \| Upper endpoint (/i.e./ least upper bound) of the interval,
129	-- together with 'Boundary' information.
130	-- The result is convenient to use as an argument for 'interval'.
131	upperBound' :: Interval r -> (Extended r, Boundary)
132	upperBound' = \case	1✔
133	Whole -> (PosInf, Open)	1✔
134	Empty -> (NegInf, Open)	1✔
135	Point r -> (Finite r, Closed)	1✔
136	LessThan r -> (Finite r, Open)	1✔
137	LessOrEqual r -> (Finite r, Closed)	1✔
138	GreaterThan{} -> (PosInf, Open)	1✔
139	GreaterOrEqual{} -> (PosInf, Open)	1✔
140	BothClosed _ q -> (Finite q, Closed)	1✔
141	LeftOpen _ q -> (Finite q, Closed)	1✔
142	RightOpen _ q -> (Finite q, Open)	1✔
143	BothOpen _ q -> (Finite q, Open)	1✔
144
145	type role Interval nominal
146
147	instance (Ord r, Data r) => Data (Interval r) where
148	gfoldl k z x = z interval `k` lowerBound' x `k` upperBound' x	1✔
149	toConstr _ = intervalConstr	×
150	gunfold k z c = case constrIndex c of	×
151	1 -> k (k (z interval))	×
152	_ -> error "gunfold"	×
153	dataTypeOf _ = intervalDataType	×
154	dataCast1 f = gcast1 f	×
155
156	intervalConstr :: Constr
157	intervalConstr = mkConstr intervalDataType "interval" [] Prefix	×
158
159	intervalDataType :: DataType
160	intervalDataType = mkDataType "Data.Interval.Internal.Interval" [intervalConstr]	×
161
162	instance NFData r => NFData (Interval r) where
163	rnf = \case	1✔
164	Whole -> ()	1✔
165	Empty -> ()	1✔
166	Point r -> rnf r	1✔
167	LessThan r -> rnf r	1✔
168	LessOrEqual r -> rnf r	1✔
169	GreaterThan r -> rnf r	1✔
170	GreaterOrEqual r -> rnf r	1✔
171	BothClosed p q -> rnf p `seq` rnf q	1✔
172	LeftOpen p q -> rnf p `seq` rnf q	1✔
173	RightOpen p q -> rnf p `seq` rnf q	1✔
174	BothOpen p q -> rnf p `seq` rnf q	1✔
175
176	instance Hashable r => Hashable (Interval r) where
177	hashWithSalt s = \case	1✔
178	Whole -> s `hashWithSalt` (1 :: Int)	1✔
179	Empty -> s `hashWithSalt` (2 :: Int)	1✔
180	Point r -> s `hashWithSalt` (3 :: Int) `hashWithSalt` r	1✔
181	LessThan r -> s `hashWithSalt` (4 :: Int) `hashWithSalt` r	1✔
182	LessOrEqual r -> s `hashWithSalt` (5 :: Int) `hashWithSalt` r	1✔
183	GreaterThan r -> s `hashWithSalt` (6 :: Int) `hashWithSalt` r	1✔
184	GreaterOrEqual r -> s `hashWithSalt` (7 :: Int) `hashWithSalt` r	1✔
185	BothClosed p q -> s `hashWithSalt` (8 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
186	LeftOpen p q -> s `hashWithSalt` (9 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
187	RightOpen p q -> s `hashWithSalt` (10 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
188	BothOpen p q -> s `hashWithSalt` (11 :: Int) `hashWithSalt` p `hashWithSalt` q	1✔
189
190	-- \| empty (contradicting) interval
191	empty :: Ord r => Interval r
192	empty = Empty	1✔
193
194	-- \| smart constructor for 'Interval'
195	interval
196	:: (Ord r)
197	=> (Extended r, Boundary) -- ^ lower bound and whether it is included
198	-> (Extended r, Boundary) -- ^ upper bound and whether it is included
199	-> Interval r
200	interval = \case	1✔
201	(NegInf, _) -> \case	1✔
202	(NegInf, _) -> Empty	1✔
203	(Finite r, Open) -> LessThan r	1✔
204	(Finite r, Closed) -> LessOrEqual r	1✔
205	(PosInf, _) -> Whole	1✔
206	(Finite p, Open) -> \case	1✔
207	(NegInf, _) -> Empty	1✔
208	(Finite q, Open)
209	\| p < q -> BothOpen p q	1✔
210	\| otherwise -> Empty	1✔
211	(Finite q, Closed)
212	\| p < q -> LeftOpen p q	1✔
213	\| otherwise -> Empty	1✔
214	(PosInf, _) -> GreaterThan p	1✔
215	(Finite p, Closed) -> \case	1✔
216	(NegInf, _) -> Empty	1✔
217	(Finite q, Open)
218	\| p < q -> RightOpen p q	1✔
219	\| otherwise -> Empty	1✔
220	(Finite q, Closed) -> case p `compare` q of	1✔
221	LT -> BothClosed p q	1✔
222	EQ -> Point p	1✔
223	GT -> Empty	1✔
224	(PosInf, _) -> GreaterOrEqual p	1✔
225	(PosInf, _) -> const Empty	1✔
226	{-# INLINE interval #-}

msakai / data-interval / 74

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