module PostgresqlTypes.Multirange
( Multirange,
toRangeList,
toRangeVector,
normalizeFromRangeList,
refineFromRangeList,
)
where
import qualified Data.Attoparsec.Text as Attoparsec
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import PostgresqlTypes.Algebra
import qualified PostgresqlTypes.Multirange.List
import qualified PostgresqlTypes.Multirange.QuickCheckGen as QuickCheckGen
import PostgresqlTypes.Prelude
import PostgresqlTypes.Range (Range)
import qualified PostgresqlTypes.Range as Range
import PostgresqlTypes.Via
import qualified PtrPeeker
import qualified PtrPoker.Write as Write
import qualified Test.QuickCheck as QuickCheck
import qualified TextBuilder
newtype Multirange a = Multirange (Vector (Range a))
deriving stock (Multirange a -> Multirange a -> Bool
(Multirange a -> Multirange a -> Bool)
-> (Multirange a -> Multirange a -> Bool) -> Eq (Multirange a)
forall a. Eq a => Multirange a -> Multirange a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Multirange a -> Multirange a -> Bool
== :: Multirange a -> Multirange a -> Bool
$c/= :: forall a. Eq a => Multirange a -> Multirange a -> Bool
/= :: Multirange a -> Multirange a -> Bool
Eq, (forall a b. (a -> b) -> Multirange a -> Multirange b)
-> (forall a b. a -> Multirange b -> Multirange a)
-> Functor Multirange
forall a b. a -> Multirange b -> Multirange a
forall a b. (a -> b) -> Multirange a -> Multirange b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Multirange a -> Multirange b
fmap :: forall a b. (a -> b) -> Multirange a -> Multirange b
$c<$ :: forall a b. a -> Multirange b -> Multirange a
<$ :: forall a b. a -> Multirange b -> Multirange a
Functor)
deriving (Int -> Multirange a -> ShowS
[Multirange a] -> ShowS
Multirange a -> String
(Int -> Multirange a -> ShowS)
-> (Multirange a -> String)
-> ([Multirange a] -> ShowS)
-> Show (Multirange a)
forall a. IsMultirangeElement a => Int -> Multirange a -> ShowS
forall a. IsMultirangeElement a => [Multirange a] -> ShowS
forall a. IsMultirangeElement a => Multirange a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. IsMultirangeElement a => Int -> Multirange a -> ShowS
showsPrec :: Int -> Multirange a -> ShowS
$cshow :: forall a. IsMultirangeElement a => Multirange a -> String
show :: Multirange a -> String
$cshowList :: forall a. IsMultirangeElement a => [Multirange a] -> ShowS
showList :: [Multirange a] -> ShowS
Show, ReadPrec [Multirange a]
ReadPrec (Multirange a)
Int -> ReadS (Multirange a)
ReadS [Multirange a]
(Int -> ReadS (Multirange a))
-> ReadS [Multirange a]
-> ReadPrec (Multirange a)
-> ReadPrec [Multirange a]
-> Read (Multirange a)
forall a. IsMultirangeElement a => ReadPrec [Multirange a]
forall a. IsMultirangeElement a => ReadPrec (Multirange a)
forall a. IsMultirangeElement a => Int -> ReadS (Multirange a)
forall a. IsMultirangeElement a => ReadS [Multirange a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. IsMultirangeElement a => Int -> ReadS (Multirange a)
readsPrec :: Int -> ReadS (Multirange a)
$creadList :: forall a. IsMultirangeElement a => ReadS [Multirange a]
readList :: ReadS [Multirange a]
$creadPrec :: forall a. IsMultirangeElement a => ReadPrec (Multirange a)
readPrec :: ReadPrec (Multirange a)
$creadListPrec :: forall a. IsMultirangeElement a => ReadPrec [Multirange a]
readListPrec :: ReadPrec [Multirange a]
Read, String -> Multirange a
(String -> Multirange a) -> IsString (Multirange a)
forall a. IsMultirangeElement a => String -> Multirange a
forall a. (String -> a) -> IsString a
$cfromString :: forall a. IsMultirangeElement a => String -> Multirange a
fromString :: String -> Multirange a
IsString) via (ViaIsScalar (Multirange a))
instance (IsMultirangeElement a) => IsScalar (Multirange a) where
schemaName :: Tagged (Multirange a) (Maybe Text)
schemaName = Maybe Text -> Tagged (Multirange a) (Maybe Text)
forall {k} (s :: k) b. b -> Tagged s b
Tagged Maybe Text
forall a. Maybe a
Nothing
typeName :: Tagged (Multirange a) Text
typeName = Tagged a Text -> Tagged (Multirange a) Text
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag (forall a. IsMultirangeElement a => Tagged a Text
multirangeTypeName @a)
baseOid :: Tagged (Multirange a) (Maybe Word32)
baseOid = Tagged a (Maybe Word32) -> Tagged (Multirange a) (Maybe Word32)
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag (forall a. IsMultirangeElement a => Tagged a (Maybe Word32)
multirangeBaseOid @a)
arrayOid :: Tagged (Multirange a) (Maybe Word32)
arrayOid = Tagged a (Maybe Word32) -> Tagged (Multirange a) (Maybe Word32)
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag (forall a. IsMultirangeElement a => Tagged a (Maybe Word32)
multirangeArrayOid @a)
typeParams :: Tagged (Multirange a) [Text]
typeParams = Tagged (Range a) [Text] -> Tagged (Multirange a) [Text]
forall {k1} {k2} (s :: k1) b (t :: k2). Tagged s b -> Tagged t b
retag (forall a. IsScalar a => Tagged a [Text]
typeParams @(Range a))
binaryEncoder :: Multirange a -> Write
binaryEncoder = \case
Multirange Vector (Range a)
ranges ->
[Write] -> Write
forall a. Monoid a => [a] -> a
mconcat
[ Word32 -> Write
Write.bWord32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector (Range a) -> Int
forall a. Vector a -> Int
Vector.length Vector (Range a)
ranges)),
(Range a -> Write) -> Vector (Range a) -> Write
forall m a. Monoid m => (a -> m) -> Vector a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Range a -> Write
forall {a}. IsScalar a => a -> Write
renderRange Vector (Range a)
ranges
]
where
renderRange :: a -> Write
renderRange a
range =
let write :: Write
write = a -> Write
forall {a}. IsScalar a => a -> Write
binaryEncoder a
range
in Word32 -> Write
Write.bWord32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Write -> Int
Write.writeSize Write
write)) Write -> Write -> Write
forall a. Semigroup a => a -> a -> a
<> Write
write
binaryDecoder :: Variable (Either DecodingError (Multirange a))
binaryDecoder = ExceptT DecodingError Variable (Multirange a)
-> Variable (Either DecodingError (Multirange a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
Word32
numRanges <- Variable Word32 -> ExceptT DecodingError Variable Word32
forall (m :: * -> *) a. Monad m => m a -> ExceptT DecodingError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
Fixed Word32 -> Variable Word32
forall a. Fixed a -> Variable a
PtrPeeker.fixed Fixed Word32
PtrPeeker.beUnsignedInt4
[Range a]
ranges <- Int
-> ExceptT DecodingError Variable (Range a)
-> ExceptT DecodingError Variable [Range a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
numRanges) do
Int32
size <- Variable Int32 -> ExceptT DecodingError Variable Int32
forall (m :: * -> *) a. Monad m => m a -> ExceptT DecodingError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
Fixed Int32 -> Variable Int32
forall a. Fixed a -> Variable a
PtrPeeker.fixed Fixed Int32
PtrPeeker.beSignedInt4
Bool
-> ExceptT DecodingError Variable ()
-> ExceptT DecodingError Variable ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
size Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0) do
DecodingError -> ExceptT DecodingError Variable ()
forall a. DecodingError -> ExceptT DecodingError Variable a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Text] -> DecodingErrorReason -> DecodingError
DecodingError [Text
"range-size"] (Text -> Text -> DecodingErrorReason
UnsupportedValueDecodingErrorReason Text
"Expecting >= 0" (TextBuilder -> Text
TextBuilder.toText (Int32 -> TextBuilder
forall a. Integral a => a -> TextBuilder
TextBuilder.decimal Int32
size))))
Variable (Either DecodingError (Range a))
-> ExceptT DecodingError Variable (Range a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT do
Int
-> Variable (Either DecodingError (Range a))
-> Variable (Either DecodingError (Range a))
forall a. Int -> Variable a -> Variable a
PtrPeeker.forceSize (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
size) do
forall a. IsScalar a => Variable (Either DecodingError a)
binaryDecoder @(Range a)
pure (Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange ([Range a] -> Vector (Range a)
forall a. [a] -> Vector a
Vector.fromList [Range a]
ranges))
textualEncoder :: Multirange a -> TextBuilder
textualEncoder = \case
Multirange Vector (Range a)
ranges ->
[TextBuilder] -> TextBuilder
forall a. Monoid a => [a] -> a
mconcat
[ TextBuilder
"{",
TextBuilder -> [TextBuilder] -> TextBuilder
forall (f :: * -> *).
Foldable f =>
TextBuilder -> f TextBuilder -> TextBuilder
TextBuilder.intercalate TextBuilder
"," (Vector TextBuilder -> [TextBuilder]
forall a. Vector a -> [a]
Vector.toList ((Range a -> TextBuilder) -> Vector (Range a) -> Vector TextBuilder
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map (forall a. IsScalar a => a -> TextBuilder
textualEncoder @(Range a)) Vector (Range a)
ranges)),
TextBuilder
"}"
]
textualDecoder :: Parser (Multirange a)
textualDecoder = do
Char
_ <- Char -> Parser Char
Attoparsec.char Char
'{'
Parser ()
Attoparsec.skipSpace
[Range a]
ranges <- (forall a. IsScalar a => Parser a
textualDecoder @(Range a)) Parser (Range a) -> Parser () -> Parser Text [Range a]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`Attoparsec.sepBy` (Parser ()
Attoparsec.skipSpace Parser () -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Char
Attoparsec.char Char
',' Parser Char -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
Attoparsec.skipSpace)
Parser ()
Attoparsec.skipSpace
Char
_ <- Char -> Parser Char
Attoparsec.char Char
'}'
Parser ()
Attoparsec.skipSpace
pure (Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange ([Range a] -> Vector (Range a)
forall a. [a] -> Vector a
Vector.fromList [Range a]
ranges))
instance (IsRangeElement a, Arbitrary a, Ord a) => Arbitrary (Multirange a) where
arbitrary :: Gen (Multirange a)
arbitrary = do
Int
size <- Gen Int
QuickCheck.getSize
[(Int, Gen (Multirange a))] -> Gen (Multirange a)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QuickCheck.frequency
[ ( Int
1,
Multirange a -> Gen (Multirange a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange Vector (Range a)
forall a. Vector a
Vector.empty)
),
( Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
size,
do
Bool
lowerInfinity <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
Bool
upperInfinity <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
Int
numRanges <- (Int, Int) -> Gen Int
QuickCheck.chooseInt (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
size)
let numBounds :: Int
numBounds =
Int
numRanges Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
1 Int
0 Bool
lowerInfinity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Bool -> Int
forall a. a -> a -> Bool -> a
bool Int
1 Int
0 Bool
upperInfinity
Set a
bounds <- Int -> Gen a -> Gen (Set a)
forall a. Ord a => Int -> Gen a -> Gen (Set a)
QuickCheckGen.setOfSize Int
numBounds (forall a. Arbitrary a => Gen a
arbitrary @a)
let preparedBounds :: [Maybe a]
preparedBounds =
[[Maybe a]] -> [Maybe a]
forall a. Monoid a => [a] -> a
mconcat
[ if Bool
lowerInfinity then [Maybe a
forall a. Maybe a
Nothing] else [],
(a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
bounds),
if Bool
upperInfinity then [Maybe a
forall a. Maybe a
Nothing] else []
]
pairs :: [(Maybe a, Maybe a)]
pairs =
[Maybe a] -> [(Maybe a, Maybe a)]
forall a. [a] -> [(a, a)]
PostgresqlTypes.Multirange.List.toPairs [Maybe a]
preparedBounds
ranges :: [Range a]
ranges =
((Maybe a, Maybe a) -> Range a)
-> [(Maybe a, Maybe a)] -> [Range a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe a -> Maybe a -> Range a) -> (Maybe a, Maybe a) -> Range a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe a -> Maybe a -> Range a
forall a. Ord a => Maybe a -> Maybe a -> Range a
Range.normalizeBounded) [(Maybe a, Maybe a)]
pairs :: [Range a]
Multirange a -> Gen (Multirange a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange ([Range a] -> Vector (Range a)
forall a. [a] -> Vector a
Vector.fromList [Range a]
ranges))
)
]
instance (Hashable a) => Hashable (Multirange a) where
hashWithSalt :: Int -> Multirange a -> Int
hashWithSalt Int
salt (Multirange Vector (Range a)
ranges) = Int -> [Range a] -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (Vector (Range a) -> [Range a]
forall a. Vector a -> [a]
Vector.toList Vector (Range a)
ranges)
toRangeList :: Multirange a -> [Range a]
toRangeList :: forall a. Multirange a -> [Range a]
toRangeList (Multirange Vector (Range a)
ranges) = Vector (Range a) -> [Range a]
forall a. Vector a -> [a]
Vector.toList Vector (Range a)
ranges
toRangeVector :: Multirange a -> Vector (Range a)
toRangeVector :: forall a. Multirange a -> Vector (Range a)
toRangeVector (Multirange Vector (Range a)
ranges) = Vector (Range a)
ranges
normalizeFromRangeList :: (Ord a) => [Range a] -> Multirange a
normalizeFromRangeList :: forall a. Ord a => [Range a] -> Multirange a
normalizeFromRangeList = Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange (Vector (Range a) -> Multirange a)
-> ([Range a] -> Vector (Range a)) -> [Range a] -> Multirange a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Range a] -> Vector (Range a)
forall a. [a] -> Vector a
Vector.fromList ([Range a] -> Vector (Range a))
-> ([Range a] -> [Range a]) -> [Range a] -> Vector (Range a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Range a] -> [Range a]
forall {a}. Ord a => [Range a] -> [Range a]
mergeRanges ([Range a] -> [Range a])
-> ([Range a] -> [Range a]) -> [Range a] -> [Range a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Range a] -> [Range a]
forall {a}. Ord a => [a] -> [a]
sortRanges ([Range a] -> [Range a])
-> ([Range a] -> [Range a]) -> [Range a] -> [Range a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Range a] -> [Range a]
forall {a}. [Range a] -> [Range a]
filterNonEmpty
where
filterNonEmpty :: [Range a] -> [Range a]
filterNonEmpty = (Range a -> Bool) -> [Range a] -> [Range a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Range a -> Bool) -> Range a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Range a -> Bool
forall a. Range a -> Bool
Range.isEmpty)
sortRanges :: [a] -> [a]
sortRanges = [a] -> [a]
forall {a}. Ord a => [a] -> [a]
sort
mergeRanges :: [Range a] -> [Range a]
mergeRanges [] = []
mergeRanges [Range a
r] = [Range a
r]
mergeRanges (Range a
r1 : Range a
r2 : [Range a]
rs) =
case Range a -> Range a -> Maybe (Range a)
forall a. Ord a => Range a -> Range a -> Maybe (Range a)
Range.mergeIfOverlappingOrAdjacent Range a
r1 Range a
r2 of
Just Range a
merged -> [Range a] -> [Range a]
mergeRanges (Range a
merged Range a -> [Range a] -> [Range a]
forall a. a -> [a] -> [a]
: [Range a]
rs)
Maybe (Range a)
Nothing -> Range a
r1 Range a -> [Range a] -> [Range a]
forall a. a -> [a] -> [a]
: [Range a] -> [Range a]
mergeRanges (Range a
r2 Range a -> [Range a] -> [Range a]
forall a. a -> [a] -> [a]
: [Range a]
rs)
refineFromRangeList :: (Ord a) => [Range a] -> Maybe (Multirange a)
refineFromRangeList :: forall a. Ord a => [Range a] -> Maybe (Multirange a)
refineFromRangeList [Range a]
ranges =
let Multirange Vector (Range a)
normalized = [Range a] -> Multirange a
forall a. Ord a => [Range a] -> Multirange a
normalizeFromRangeList [Range a]
ranges
unnormalized :: Vector (Range a)
unnormalized = [Range a] -> Vector (Range a)
forall a. [a] -> Vector a
Vector.fromList [Range a]
ranges
in if Vector (Range a)
unnormalized Vector (Range a) -> Vector (Range a) -> Bool
forall a. Eq a => a -> a -> Bool
== Vector (Range a)
normalized
then Multirange a -> Maybe (Multirange a)
forall a. a -> Maybe a
Just (Vector (Range a) -> Multirange a
forall a. Vector (Range a) -> Multirange a
Multirange Vector (Range a)
normalized)
else Maybe (Multirange a)
forall a. Maybe a
Nothing