{-# LANGUAGE FlexibleInstances #-}
module Data.Ranges 
(range, ranges, Range, Ranges, inRange, inRanges, toSet, single, addRange)
where

import Data.Set (Set)
import qualified Data.Set as Set

data Ord a => Range a = Single !a | Range !a !a
instance (Ord a, Show a) => Show (Range a) where
	show :: Range a -> String
show (Single a
x) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(", a -> String
forall a. Show a => a -> String
show a
x, String
")"]
	show (Range a
x a
y) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"(", a -> String
forall a. Show a => a -> String
show a
x, String
"–", a -> String
forall a. Show a => a -> String
show a
y, String
")"]

newtype Ord a => Ranges a = Ranges [Range a] deriving Int -> Ranges a -> ShowS
[Ranges a] -> ShowS
Ranges a -> String
(Int -> Ranges a -> ShowS)
-> (Ranges a -> String) -> ([Ranges a] -> ShowS) -> Show (Ranges a)
forall a. (Ord a, Show a) => Int -> Ranges a -> ShowS
forall a. (Ord a, Show a) => [Ranges a] -> ShowS
forall a. (Ord a, Show a) => Ranges a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ranges a] -> ShowS
$cshowList :: forall a. (Ord a, Show a) => [Ranges a] -> ShowS
show :: Ranges a -> String
$cshow :: forall a. (Ord a, Show a) => Ranges a -> String
showsPrec :: Int -> Ranges a -> ShowS
$cshowsPrec :: forall a. (Ord a, Show a) => Int -> Ranges a -> ShowS
Show

-- | A rather hacked-up instance.
--   This is to support fast lookups using 'Data.Set' (see 'toSet').
instance (Ord a) => Eq (Range a) where
	(Single a
x) == :: Range a -> Range a -> Bool
== (Single a
y) = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
	(Single a
a) == (Range a
x a
y) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
a Bool -> Bool -> Bool
&& a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
	(Range a
x a
y) == (Single a
a) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
a Bool -> Bool -> Bool
&& a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
	(Range a
lx a
ux) == (Range a
ly a
uy) = (a
lx a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
uy Bool -> Bool -> Bool
&& a
ux a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
ly) Bool -> Bool -> Bool
|| (a
ly a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
ux Bool -> Bool -> Bool
&& a
uy a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
lx)

instance (Ord a) => Ord (Range a) where
	(Single a
x) <= :: Range a -> Range a -> Bool
<= (Single a
y) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
	(Single a
x) <= (Range a
y a
_) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
	(Range a
_ a
x) <= (Single a
y) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y
	(Range a
_ a
x) <= (Range a
y a
_) = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y

-- | A range consisting of a single value.
single :: (Ord a) => a -> Range a
single :: a -> Range a
single a
x = a -> Range a
forall a. a -> Range a
Single a
x

-- | Construct a 'Range' from a lower and upper bound.
range :: (Ord a) => a -> a -> Range a
range :: a -> a -> Range a
range a
l a
u
	| a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
u = a -> a -> Range a
forall a. a -> a -> Range a
Range a
l a
u
	| Bool
otherwise = String -> Range a
forall a. HasCallStack => String -> a
error String
"lower bound must be smaller than upper bound"

-- | Construct a 'Ranges' from a list of lower and upper bounds.
ranges :: (Ord a) => [Range a] -> Ranges a
ranges :: [Range a] -> Ranges a
ranges = [Range a] -> Ranges a
forall a. [Range a] -> Ranges a
Ranges ([Range a] -> Ranges a)
-> ([Range a] -> [Range a]) -> [Range a] -> Ranges a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range a -> [Range a] -> [Range a])
-> [Range a] -> [Range a] -> [Range a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([Range a] -> Range a -> [Range a])
-> Range a -> [Range a] -> [Range a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Range a] -> Range a -> [Range a]
forall a. Ord a => [Range a] -> Range a -> [Range a]
mergeRanges) []

-- | Tests if a given range contains a particular value.
inRange :: (Ord a) => a -> Range a -> Bool
inRange :: a -> Range a -> Bool
inRange a
x Range a
y = a -> Range a
forall a. a -> Range a
Single a
x Range a -> Range a -> Bool
forall a. Eq a => a -> a -> Bool
== Range a
y

-- | Tests if any of the ranges contains a particular value.
inRanges :: (Ord a) => a -> Ranges a -> Bool
inRanges :: a -> Ranges a -> Bool
inRanges a
x (Ranges [Range a]
xs) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> ([Range a] -> [Bool]) -> [Range a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range a -> Bool) -> [Range a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (a
x a -> Range a -> Bool
forall a. Ord a => a -> Range a -> Bool
`inRange`) ([Range a] -> Bool) -> [Range a] -> Bool
forall a b. (a -> b) -> a -> b
$ [Range a]
xs

mergeRange :: (Ord a) => Range a -> Range a -> Either (Range a) (Range a)
mergeRange :: Range a -> Range a -> Either (Range a) (Range a)
mergeRange Range a
x Range a
y =
	if Range a
x Range a -> Range a -> Bool
forall a. Eq a => a -> a -> Bool
== Range a
y
		then Range a -> Either (Range a) (Range a)
forall a b. b -> Either a b
Right (Range a -> Either (Range a) (Range a))
-> Range a -> Either (Range a) (Range a)
forall a b. (a -> b) -> a -> b
$ Range a -> Range a -> Range a
forall a. Ord a => Range a -> Range a -> Range a
minMax Range a
x Range a
y
		else Range a -> Either (Range a) (Range a)
forall a b. a -> Either a b
Left (Range a -> Either (Range a) (Range a))
-> Range a -> Either (Range a) (Range a)
forall a b. (a -> b) -> a -> b
$ Range a
x

minMax :: (Ord a) => Range a -> Range a -> Range a
minMax :: Range a -> Range a -> Range a
minMax (Range a
lx a
ux) (Range a
ly a
uy) = a -> a -> Range a
forall a. a -> a -> Range a
Range (a -> a -> a
forall a. Ord a => a -> a -> a
min a
lx a
ly) (a -> a -> a
forall a. Ord a => a -> a -> a
max a
ux a
uy)
minMax (Single a
_) Range a
y = Range a
y
minMax x :: Range a
x@(Range a
_ a
_) (Single a
_) = Range a
x

-- | Allows quick lookups using ranges.
toSet :: (Ord a) => Ranges a -> Set (Range a)
toSet :: Ranges a -> Set (Range a)
toSet (Ranges [Range a]
x) = [Range a] -> Set (Range a)
forall a. Ord a => [a] -> Set a
Set.fromList [Range a]
x

addRange :: (Ord a) => Ranges a -> Range a -> Ranges a
addRange :: Ranges a -> Range a -> Ranges a
addRange (Ranges [Range a]
x) = [Range a] -> Ranges a
forall a. [Range a] -> Ranges a
Ranges ([Range a] -> Ranges a)
-> (Range a -> [Range a]) -> Range a -> Ranges a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Range a] -> Range a -> [Range a]
forall a. Ord a => [Range a] -> Range a -> [Range a]
mergeRanges [Range a]
x

mergeRanges :: (Ord a) => [Range a] -> Range a -> [Range a]
mergeRanges :: [Range a] -> Range a -> [Range a]
mergeRanges [] Range a
y = [Range a
y]
mergeRanges (Range a
x:[Range a]
xs) Range a
y = case Range a -> Range a -> Either (Range a) (Range a)
forall a. Ord a => Range a -> Range a -> Either (Range a) (Range a)
mergeRange Range a
x Range a
y of
		Right Range a
z -> [Range a] -> Range a -> [Range a]
forall a. Ord a => [Range a] -> Range a -> [Range a]
mergeRanges [Range a]
xs Range a
z
		Left Range a
x -> Range a
x Range a -> [Range a] -> [Range a]
forall a. a -> [a] -> [a]
: ([Range a] -> Range a -> [Range a]
forall a. Ord a => [Range a] -> Range a -> [Range a]
mergeRanges [Range a]
xs Range a
y)