From 35ced526d2db5d8a1d1f152f53cef6490b40e00a Mon Sep 17 00:00:00 2001 From: Shane O'Brien Date: Sun, 22 Mar 2026 22:35:56 +0000 Subject: [PATCH] Add preliminary support for PostgreSQL ranges --- .../20260322_223524_shane.obrien_range.md | 3 + rel8.cabal | 7 + src/Rel8/Aggregate/Range.hs | 21 ++ src/Rel8/Data/Range.hs | 338 ++++++++++++++++++ src/Rel8/Expr/Range.hs | 28 ++ src/Rel8/Range.hs | 33 ++ src/Rel8/Type/Monoid.hs | 6 + src/Rel8/Type/Range.hs | 95 +++++ src/Rel8/Type/Semigroup.hs | 6 + tests/Main.hs | 84 ++++- 10 files changed, 619 insertions(+), 2 deletions(-) create mode 100644 changelog.d/20260322_223524_shane.obrien_range.md create mode 100644 src/Rel8/Aggregate/Range.hs create mode 100644 src/Rel8/Data/Range.hs create mode 100644 src/Rel8/Expr/Range.hs create mode 100644 src/Rel8/Range.hs create mode 100644 src/Rel8/Type/Range.hs diff --git a/changelog.d/20260322_223524_shane.obrien_range.md b/changelog.d/20260322_223524_shane.obrien_range.md new file mode 100644 index 00000000..050bbfd2 --- /dev/null +++ b/changelog.d/20260322_223524_shane.obrien_range.md @@ -0,0 +1,3 @@ +### Added + +- Added preliminary support for PostgreSQL ranges. diff --git a/rel8.cabal b/rel8.cabal index 2703f99f..8f053e3a 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -33,6 +33,7 @@ library , hasql >= 1.8 && < 1.10 , iproute ^>= 1.7 , opaleye ^>= 0.10.2.1 + , postgresql-binary ^>= 0.14.2 , pretty , profunctors , product-profunctors @@ -70,6 +71,7 @@ library Rel8.Expr.Num Rel8.Expr.Text Rel8.Expr.Time + Rel8.Range Rel8.Table.Verify Rel8.Tabulate @@ -77,6 +79,7 @@ library Rel8.Aggregate Rel8.Aggregate.Fold Rel8.Aggregate.Function + Rel8.Aggregate.Range Rel8.Column Rel8.Column.ADT @@ -88,6 +91,8 @@ library Rel8.Column.Null Rel8.Column.These + Rel8.Data.Range + Rel8.Expr Rel8.Expr.Aggregate Rel8.Expr.Array @@ -101,6 +106,7 @@ library Rel8.Expr.Opaleye Rel8.Expr.Ord Rel8.Expr.Order + Rel8.Expr.Range Rel8.Expr.Read Rel8.Expr.Sequence Rel8.Expr.Serialize @@ -239,6 +245,7 @@ library Rel8.Type.Parser Rel8.Type.Parser.ByteString Rel8.Type.Parser.Time + Rel8.Type.Range Rel8.Type.ReadShow Rel8.Type.Semigroup Rel8.Type.String diff --git a/src/Rel8/Aggregate/Range.hs b/src/Rel8/Aggregate/Range.hs new file mode 100644 index 00000000..2d7e598d --- /dev/null +++ b/src/Rel8/Aggregate/Range.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Rel8.Aggregate.Range ( + rangeAgg, +) where + +-- base +import Prelude + +-- rel8 +import Rel8.Aggregate (Aggregator', toAggregator) +import Rel8.Aggregate.Function (aggregateFunction) +import Rel8.Data.Range (Multirange, Range) +import Rel8.Expr (Expr) +import Rel8.Type.Range (DBRange) + + +rangeAgg :: + DBRange a => + Aggregator' fold (Expr (Range a)) (Expr (Multirange a)) +rangeAgg = toAggregator mempty $ aggregateFunction "range_agg" diff --git a/src/Rel8/Data/Range.hs b/src/Rel8/Data/Range.hs new file mode 100644 index 00000000..3a85ef13 --- /dev/null +++ b/src/Rel8/Data/Range.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Rel8.Data.Range ( + Bound (Incl, Excl, Inf), + Range (Empty, Range), + quoteRange, + mapRange, + Multirange (Multirange), + primMultirange, +) where + +-- attoparsec +import qualified Data.Attoparsec.ByteString.Char8 as A + +-- base +import Control.Applicative (many, optional, (<|>)) +import Control.Monad ((>=>)) +import Data.Foldable (fold) +import Data.Functor (void) +import Data.Functor.Contravariant ((>$<)) +import Prelude + +-- bytestring +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as L + +-- hasql +import qualified Hasql.Decoders as Decoder +import qualified Hasql.Encoders as Encoder + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- postgresql-binary +import PostgreSQL.Binary.Range (Bound (Incl, Excl, Inf), Range (Empty, Range)) +import qualified PostgreSQL.Binary.Range as PostgreSQL + +-- rel8 +import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Builder.Fold (interfoldMap) +import Rel8.Type.Decoder (Decoder (Decoder)) +import qualified Rel8.Type.Decoder +import Rel8.Type.Encoder (Encoder (Encoder)) +import qualified Rel8.Type.Encoder +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Information (TypeInformation (TypeInformation)) +import qualified Rel8.Type.Information +import Rel8.Type.Name (TypeName (TypeName)) +import qualified Rel8.Type.Name +import Rel8.Type.Ord (DBOrd) +import Rel8.Type.Range ( + DBRange, + rangeTypeName, rangeEncoder, rangeDecoder, + multirangeTypeName, multirangeEncoder, multirangeDecoder, + ) +import Rel8.Type.Parser (parse) + + +newtype Multirange a = Multirange (PostgreSQL.Multirange a) + deriving (Eq, Ord, Show) + + +instance DBRange a => DBType (Range a) where + typeInformation = + rangeTypeInformation name rangeEncoder rangeDecoder element + where + name = rangeTypeName @a + element = typeInformation @a + + +instance DBRange a => DBEq (Range a) + + +instance DBRange a => DBOrd (Range a) + + +instance DBRange a => DBType (Multirange a) where + typeInformation = + multirangeTypeInformation + multiname + name + multirangeEncoder + multirangeDecoder + element + where + multiname = multirangeTypeName @a + name = rangeTypeName @a + element = typeInformation @a + + +instance DBRange a => DBEq (Multirange a) + + +instance DBRange a => DBOrd (Multirange a) + + +rangeTypeInformation :: + QualifiedName -> + Encoder.Value (Range a) -> + Decoder.Value (Range a) -> + TypeInformation a -> + TypeInformation (Range a) +rangeTypeInformation name encoder decoder element = + TypeInformation + { encode = + Encoder + { binary = encoder + , text = buildRange . mapRange (render . element.encode.text) + , quote = quoteRange name . mapRange element.encode.quote + } + , decode = + Decoder + { binary = decoder + , text = parseRange >=> traverseRange element.decode.text + } + , delimiter = ',' + , typeName = + TypeName + { name + , modifiers = [] + , arrayDepth = 0 + } + } + where + render = L.toStrict . toLazyByteString + + +multirangeTypeInformation :: + QualifiedName -> + QualifiedName -> + Encoder.Value (PostgreSQL.Multirange a) -> + Decoder.Value (PostgreSQL.Multirange a) -> + TypeInformation a -> + TypeInformation (Multirange a) +multirangeTypeInformation multiname name encoder decoder element = + TypeInformation + { encode = + Encoder + { binary = (\(Multirange ranges) -> ranges) >$< encoder + , text = + buildMultirange . mapMultirange (render . element.encode.text) + , quote = + quoteMultirange multiname name + . mapMultirange element.encode.quote + } + , decode = + Decoder + { binary = Multirange <$> decoder + , text = parseMultirange >=> traverseMultirange element.decode.text + } + , delimiter = ',' + , typeName = + TypeName + { name = multiname + , modifiers = [] + , arrayDepth = 0 + } + } + where + render = L.toStrict . toLazyByteString + + +buildRange :: Range ByteString -> Builder +buildRange = \case + Empty -> B.string7 "empty" + Range lo hi -> lower <> B.char8 ',' <> upper + where + lower = case lo of + Incl a -> B.char8 '[' <> element a + Excl a -> B.char8 '(' <> element a + Inf -> B.char8 '(' + upper = case hi of + Incl a -> element a <> B.char8 ']' + Excl a -> element a <> B.char8 ')' + Inf -> B.char8 ')' + where + element bytes + | BS.null bytes = B.string7 "\"\"" + | BS.any (A.inClass escapeClass) bytes = escape bytes + | otherwise = B.byteString bytes + escapeClass = ",()[]\\\" \t\n\r\v\f" + escape bytes = + B.char8 '"' <> BS.foldr ((<>) . go) mempty bytes <> B.char8 '"' + where + go = \case + '"' -> B.string7 "\\\"" + '\\' -> B.string7 "\\\\" + c -> B.char8 c + + +quoteRange :: QualifiedName -> Range Opaleye.PrimExpr -> Opaleye.PrimExpr +quoteRange name = \case + Empty -> + Opaleye.ConstExpr (Opaleye.StringLit "empty") + Range lo hi -> + Opaleye.FunExpr constructor [lower, upper, bounds] + where + lower = case lo of + Incl a -> a + Excl a -> a + Inf -> Opaleye.ConstExpr Opaleye.NullLit + upper = case hi of + Incl a -> a + Excl a -> a + Inf -> Opaleye.ConstExpr Opaleye.NullLit + bounds = Opaleye.ConstExpr (Opaleye.StringLit (l : h : [])) + where + l = case lo of + Incl _ -> '[' + _ -> '(' + h = case hi of + Incl _ -> ']' + _ -> ')' + where + constructor = showQualifiedName name + + +parseRange :: ByteString -> Either String (Range ByteString) +parseRange = parse $ empty <|> nonEmpty + where + empty = Empty <$ A.string "empty" + nonEmpty = rangeParser + + +rangeParser :: A.Parser (Range ByteString) +rangeParser = do + lo <- Incl <$ A.char '[' <|> Excl <$ A.char '(' + mlower <- optional element + void $ A.char ',' + mupper <- optional element + hi <- Incl <$ A.char ']' <|> Excl <$ A.char ')' + let + lower = maybe Inf lo mlower + upper = maybe Inf hi mupper + pure $ Range lower upper + where + element = quoted <|> unquoted + where + unquoted = A.takeWhile1 (A.notInClass ",)]") + quoted = A.char '"' *> contents <* A.char '"' + where + contents = fold <$> many (unquote <|> unescape) + where + unquote = A.takeWhile1 (A.notInClass "\"\\") + unescape = A.char '\\' *> do + BS.singleton <$> do + A.char '\\' <|> A.char '"' + + +buildMultirange :: Multirange ByteString -> Builder +buildMultirange (Multirange ranges) = + B.char8 '{' <> interfoldMap (B.char8 ',') buildRange ranges <> B.char8 '}' + + +quoteMultirange :: + QualifiedName -> + QualifiedName -> + Multirange Opaleye.PrimExpr -> + Opaleye.PrimExpr +quoteMultirange multiname name (Multirange ranges) = + primMultirange multiname (map (cast . quoteRange name) ranges) + where + cast = Opaleye.CastExpr (showQualifiedName name) + + +primMultirange :: QualifiedName -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr +primMultirange = Opaleye.FunExpr . showQualifiedName + + +parseMultirange :: + ByteString -> + Either String (Multirange ByteString) +parseMultirange = + parse $ + Multirange <$> do + A.char '{' *> A.sepBy rangeParser (A.char ',') <* A.char '}' + + +mapBound :: (a -> b) -> Bound a -> Bound b +mapBound f = \case + Incl a -> Incl (f a) + Excl a -> Excl (f a) + Inf -> Inf + + +traverseBound :: + Applicative f => + (a -> f b) -> + Bound a -> + f (Bound b) +traverseBound f = \case + Incl a -> Incl <$> f a + Excl a -> Excl <$> f a + Inf -> pure Inf + + +mapRange :: (a -> b) -> Range a -> Range b +mapRange f = \case + Empty -> Empty + Range a b -> Range (mapBound f a) (mapBound f b) + + +traverseRange :: + Applicative f => + (a -> f b) -> + Range a -> + f (Range b) +traverseRange f = \case + Empty -> pure Empty + Range a b -> + Range <$> traverseBound f a <*> traverseBound f b + + +mapMultirange :: + (a -> b) -> + Multirange a -> + Multirange b +mapMultirange f (Multirange ranges) = Multirange (map (mapRange f) ranges) + + +traverseMultirange :: + Applicative f => + (a -> f b) -> + Multirange a -> + f (Multirange b) +traverseMultirange f (Multirange ranges) = + Multirange <$> traverse (traverseRange f) ranges diff --git a/src/Rel8/Expr/Range.hs b/src/Rel8/Expr/Range.hs new file mode 100644 index 00000000..160a35be --- /dev/null +++ b/src/Rel8/Expr/Range.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Rel8.Expr.Range ( + range, + multirange, +) where + +-- rel8 +import Rel8.Data.Range ( + Range, mapRange, quoteRange, + Multirange, primMultirange, + ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr) +import Rel8.Type.Range (DBRange, rangeTypeName, multirangeTypeName) + + +range :: forall a. DBRange a => Range (Expr a) -> Expr (Range a) +range = fromPrimExpr . quoteRange name . mapRange toPrimExpr + where + name = rangeTypeName @a + + +multirange :: forall a. DBRange a => [Expr (Range a)] -> Expr (Multirange a) +multirange = fromPrimExpr . primMultirange name . map toPrimExpr + where + name = multirangeTypeName @a diff --git a/src/Rel8/Range.hs b/src/Rel8/Range.hs new file mode 100644 index 00000000..2297291d --- /dev/null +++ b/src/Rel8/Range.hs @@ -0,0 +1,33 @@ +module Rel8.Range ( + -- * Basic range functionality + Bound (Incl, Excl, Inf), + Range (Empty, Range), + Multirange (Multirange), + range, + multirange, + rangeAgg, + + -- * Defining new range types + DBRange ( + rangeTypeName, rangeDecoder, rangeEncoder, + multirangeTypeName, multirangeDecoder, multirangeEncoder + ) +) where + +-- base +import Prelude () + +-- rel8 +import Rel8.Aggregate.Range (rangeAgg) +import Rel8.Data.Range ( + Bound (Incl, Excl, Inf), + Range (Empty, Range), + Multirange (Multirange), + ) +import Rel8.Expr.Range (range, multirange) +import Rel8.Type.Range ( + DBRange ( + rangeTypeName, rangeDecoder, rangeEncoder, + multirangeTypeName, multirangeDecoder, multirangeEncoder + ), + ) diff --git a/src/Rel8/Type/Monoid.hs b/src/Rel8/Type/Monoid.hs index d9623eac..95bde50d 100644 --- a/src/Rel8/Type/Monoid.hs +++ b/src/Rel8/Type/Monoid.hs @@ -24,11 +24,13 @@ import qualified Data.ByteString.Lazy as Lazy ( ByteString ) import Data.CaseInsensitive ( CI ) -- rel8 +import Rel8.Data.Range (Multirange (Multirange)) import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sempty ) import Rel8.Expr.Serialize ( litExpr ) import Rel8.Schema.Null ( Sql ) import Rel8.Type ( DBType, typeInformation ) +import Rel8.Type.Range (DBRange) import Rel8.Type.Semigroup ( DBSemigroup ) -- text @@ -77,3 +79,7 @@ instance DBMonoid ByteString where instance DBMonoid Lazy.ByteString where memptyExpr = litExpr "" + + +instance DBRange a => DBMonoid (Multirange a) where + memptyExpr = litExpr (Multirange []) diff --git a/src/Rel8/Type/Range.hs b/src/Rel8/Type/Range.hs new file mode 100644 index 00000000..7dfaeb39 --- /dev/null +++ b/src/Rel8/Type/Range.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Rel8.Type.Range ( + DBRange ( + rangeTypeName, rangeDecoder, rangeEncoder, + multirangeTypeName, multirangeDecoder, multirangeEncoder + ), +) where + +-- base +import Data.Int (Int32, Int64) + +-- hasql +import qualified Hasql.Decoders as Decoder +import qualified Hasql.Encoders as Encoder + +-- postgresql-binary +import qualified PostgreSQL.Binary.Range as PostgreSQL + +-- rel8 +import Rel8.Schema.QualifiedName (QualifiedName) +import Rel8.Type.Ord (DBOrd) + +-- scientific +import Data.Scientific (Scientific) + +-- time +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (LocalTime) + + +class DBOrd a => DBRange a where + rangeTypeName :: QualifiedName + rangeDecoder :: Decoder.Value (PostgreSQL.Range a) + rangeEncoder :: Encoder.Value (PostgreSQL.Range a) + + multirangeTypeName :: QualifiedName + multirangeDecoder :: Decoder.Value (PostgreSQL.Multirange a) + multirangeEncoder :: Encoder.Value (PostgreSQL.Multirange a) + + +instance DBRange Int32 where + rangeTypeName = "int4range" + rangeDecoder = Decoder.int4range + rangeEncoder = Encoder.int4range + multirangeTypeName = "int4multirange" + multirangeDecoder = Decoder.int4multirange + multirangeEncoder = Encoder.int4multirange + + +instance DBRange Int64 where + rangeTypeName = "int8range" + rangeDecoder = Decoder.int8range + rangeEncoder = Encoder.int8range + multirangeTypeName = "int8multirange" + multirangeDecoder = Decoder.int8multirange + multirangeEncoder = Encoder.int8multirange + + +instance DBRange Scientific where + rangeTypeName = "numrange" + rangeDecoder = Decoder.numrange + rangeEncoder = Encoder.numrange + multirangeTypeName = "nummultirange" + multirangeDecoder = Decoder.nummultirange + multirangeEncoder = Encoder.nummultirange + + +instance DBRange LocalTime where + rangeTypeName = "tsrange" + rangeDecoder = Decoder.tsrange + rangeEncoder = Encoder.tsrange + multirangeTypeName = "tsmultirange" + multirangeDecoder = Decoder.tsmultirange + multirangeEncoder = Encoder.tsmultirange + + +instance DBRange UTCTime where + rangeTypeName = "tstzrange" + rangeDecoder = Decoder.tstzrange + rangeEncoder = Encoder.tstzrange + multirangeTypeName = "tstzmultirange" + multirangeDecoder = Decoder.tstzmultirange + multirangeEncoder = Encoder.tstzmultirange + + +instance DBRange Day where + rangeTypeName = "daterange" + rangeDecoder = Decoder.daterange + rangeEncoder = Encoder.daterange + multirangeTypeName = "datemultirange" + multirangeDecoder = Decoder.datemultirange + multirangeEncoder = Encoder.datemultirange diff --git a/src/Rel8/Type/Semigroup.hs b/src/Rel8/Type/Semigroup.hs index c76e8e45..93f595d2 100644 --- a/src/Rel8/Type/Semigroup.hs +++ b/src/Rel8/Type/Semigroup.hs @@ -28,11 +28,13 @@ import Data.CaseInsensitive ( CI ) import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 +import Rel8.Data.Range (Multirange) import {-# SOURCE #-} Rel8.Expr ( Expr ) import Rel8.Expr.Array ( sappend, sappend1 ) import Rel8.Expr.Opaleye ( zipPrimExprsWith ) import Rel8.Schema.Null ( Sql ) import Rel8.Type ( DBType ) +import Rel8.Type.Range (DBRange) -- text import Data.Text ( Text ) @@ -85,3 +87,7 @@ instance DBSemigroup ByteString where instance DBSemigroup Lazy.ByteString where (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||)) + + +instance DBRange a => DBSemigroup (Multirange a) where + (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+)) diff --git a/tests/Main.hs b/tests/Main.hs index f26a580a..d40b3a03 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,6 +6,7 @@ {-# language DerivingVia #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} +{-# language LambdaCase #-} {-# language MonoLocalBinds #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} @@ -14,8 +15,6 @@ {-# language StandaloneDeriving #-} {-# language TypeApplications #-} -{-# language PartialTypeSignatures #-} - module Main ( main ) @@ -84,6 +83,11 @@ import Rel8 ( Result ) import qualified Rel8 import qualified Rel8.Generic.Rel8able.Test as Rel8able import qualified Rel8.Table.Verify as Verify +import Rel8.Range ( + Bound (Incl, Excl, Inf), + Range (Empty, Range), + Multirange (Multirange), + ) -- scientific import Data.Scientific ( Scientific ) @@ -586,6 +590,8 @@ testDBType getTestDatabase = testGroup "DBType instances" , dbTypeTest "JSONEncoded" genJSONEncoded , dbTypeTest "JSONBEncoded" genJSONBEncoded , dbTypeTest "Object" genObject + , dbTypeTest "Range" genRange + , dbTypeTest "Multirange" genMultirange ] where @@ -744,6 +750,80 @@ testDBType getTestDatabase = testGroup "DBType instances" genObject :: Gen Aeson.Object genObject = Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue) + genRange :: Gen (Range Scientific) + genRange = + Gen.choice + [ pure Empty + , do + (lower, upper) <- genBounds + pure (Range lower upper) + ] + + genBound :: Gen a -> Gen (Bound a) + genBound a = + Gen.choice + [ Incl <$> a + , Excl <$> a + , pure Inf + ] + + genNum :: Gen Scientific + genNum = genNumFrom (-1000) + + genNumFrom :: Scientific -> Gen Scientific + genNumFrom x = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear i 10000) + where + i = round (x * 10) + + genBounds :: Gen (Bound Scientific, Bound Scientific) + genBounds = do + lower <- genBound genNum + upper <- genUpperFrom lower + pure (lower, upper) + + genUpperFrom :: Bound Scientific -> Gen (Bound Scientific) + genUpperFrom = \case + Inf -> genBound genNum + Incl x -> genBoundGT x + Excl x -> genBoundGT x + where + genBoundGT x + | x' < 1000 = genBound $ genNumFrom x' + | otherwise = pure Inf + where + x' = x + 0.1 + + genMultirange :: Gen (Multirange Scientific) + genMultirange = Multirange <$> do + n <- Gen.integral (Range.linear @Int 0 10) + if n == 0 + then pure [] + else do + (lower, upper) <- genBounds + ranges <- go (n - 1) upper + pure (Range lower upper : ranges) + where + go n bound + | n == 0 = pure [] + | otherwise = case bound of + Inf -> pure [] + Incl x -> next x + Excl x -> next x + where + next x + | x' >= 1000 = pure [] + | otherwise = do + lower <- + Gen.choice + [ Incl <$> genNumFrom x' + , Excl <$> genNumFrom x' + ] + upper <- genUpperFrom lower + ranges <- go (n - 1) upper + pure (Range lower upper : ranges) + where + x' = x + 0.1 + testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"