diff --git a/library/PostgreSQL/Binary/Decoding.hs b/library/PostgreSQL/Binary/Decoding.hs --- a/library/PostgreSQL/Binary/Decoding.hs +++ b/library/PostgreSQL/Binary/Decoding.hs @@ -59,6 +59,26 @@ hstore, enum, refine, + + -- ** Range + int4range, + int8range, + numrange, + tsrange_int, + tsrange_float, + tstzrange_int, + tstzrange_float, + daterange, + + -- ** Multirange + int4multirange, + int8multirange, + nummultirange, + tsmultirange_int, + tsmultirange_float, + tstzmultirange_int, + tstzmultirange_float, + datemultirange, ) where @@ -78,6 +98,7 @@ import qualified PostgreSQL.Binary.Interval as Interval import qualified PostgreSQL.Binary.Numeric as Numeric import PostgreSQL.Binary.Prelude hiding (bool, drop, fail, state, take) +import qualified PostgreSQL.Binary.Range as Range import qualified PostgreSQL.Binary.Time as Time type Value = @@ -534,3 +555,155 @@ {-# INLINE refine #-} refine :: (a -> Either Text b) -> Value a -> Value b refine fn m = m >>= (either failure pure . fn) + +-- * Range + +-- | +-- One of the range types: +-- +-- * @int4range@ +-- * @int8range@ +-- * @numrange@ +-- * @tsrange@ +-- * @tstzrange@ +-- * @daterange@ +{-# INLINE range #-} +range :: Value a -> Value (Range.Range a) +range decoder = + do + flags <- byte + let emptyRange = testBit flags 0 + lowerInclusive = testBit flags 1 + upperInclusive = testBit flags 2 + lowerInfinite = testBit flags 3 + upperInfinite = testBit flags 4 + if + | emptyRange -> + pure $ Range.Empty + | lowerInfinite && upperInfinite -> + pure $ Range.Range Range.Inf Range.Inf + | lowerInfinite -> + Range.Range <$> pure Range.Inf <*> bound upperInclusive decoder + | upperInfinite -> + Range.Range <$> bound lowerInclusive decoder <*> pure Range.Inf + | otherwise -> + Range.Range <$> bound lowerInclusive decoder <*> bound upperInclusive decoder + where + bound isIncl = + onContent + >=> nonNull + >=> if isIncl then pure . Range.Incl else pure . Range.Excl + +-- | +-- @int4range@ +{-# INLINE int4range #-} +int4range :: Value (Range.Range Int32) +int4range = range int + +-- | +-- @int8range@ +{-# INLINE int8range #-} +int8range :: Value (Range.Range Int64) +int8range = range int + +-- | +-- @numrange@ +{-# INLINE numrange #-} +numrange :: Value (Range.Range Scientific) +numrange = range numeric + +-- | +-- @tsrange@ +{-# INLINE tsrange_int #-} +tsrange_int :: Value (Range.Range LocalTime) +tsrange_int = range timestamp_int + +-- | +-- @tsrange@ +{-# INLINE tsrange_float #-} +tsrange_float :: Value (Range.Range LocalTime) +tsrange_float = range timestamp_float + +-- | +-- @tstzrange@ +{-# INLINE tstzrange_int #-} +tstzrange_int :: Value (Range.Range UTCTime) +tstzrange_int = range timestamptz_int + +-- | +-- @tstzrange@ +{-# INLINE tstzrange_float #-} +tstzrange_float :: Value (Range.Range UTCTime) +tstzrange_float = range timestamptz_float + +-- | +-- @daterange@ +{-# INLINE daterange #-} +daterange :: Value (Range.Range Day) +daterange = range date + +-- * Multirange + +-- | +-- One of the multirange types: +-- +-- * @int4multirange@ +-- * @int8multirange@ +-- * @nummultirange@ +-- * @tsmultirange@ +-- * @tstzmultirange@ +-- * @datemultirange@ +{-# INLINE multirange #-} +multirange :: Value a -> Value (Range.Multirange a) +multirange decoder = + do + rangeCount <- intOfSize 4 + replicateM rangeCount (onContent (range decoder) >>= nonNull) + +-- | +-- @int4multirange@ +{-# INLINE int4multirange #-} +int4multirange :: Value (Range.Multirange Int32) +int4multirange = multirange int + +-- | +-- @int8multirange@ +{-# INLINE int8multirange #-} +int8multirange :: Value (Range.Multirange Int64) +int8multirange = multirange int + +-- | +-- @nummultirange@ +{-# INLINE nummultirange #-} +nummultirange :: Value (Range.Multirange Scientific) +nummultirange = multirange numeric + +-- | +-- @tsmultirange@ +{-# INLINE tsmultirange_int #-} +tsmultirange_int :: Value (Range.Multirange LocalTime) +tsmultirange_int = multirange timestamp_int + +-- | +-- @tsmultirange@ +{-# INLINE tsmultirange_float #-} +tsmultirange_float :: Value (Range.Multirange LocalTime) +tsmultirange_float = multirange timestamp_float + +-- | +-- @tstzmultirange@ +{-# INLINE tstzmultirange_int #-} +tstzmultirange_int :: Value (Range.Multirange UTCTime) +tstzmultirange_int = multirange timestamptz_int + +-- | +-- @tstzmultirange@ +{-# INLINE tstzmultirange_float #-} +tstzmultirange_float :: Value (Range.Multirange UTCTime) +tstzmultirange_float = multirange timestamptz_float + +-- | +-- @datemultirange@ +{-# INLINE datemultirange #-} +datemultirange :: Value (Range.Multirange Day) +datemultirange = multirange date diff --git a/library/PostgreSQL/Binary/Encoding.hs b/library/PostgreSQL/Binary/Encoding.hs --- a/library/PostgreSQL/Binary/Encoding.hs +++ b/library/PostgreSQL/Binary/Encoding.hs @@ -65,6 +65,26 @@ Composite, field, nullField, + + -- * Range + int4range, + int8range, + numrange, + tsrange_int, + tsrange_float, + tstzrange_int, + tstzrange_float, + daterange, + + -- * Multirange + int4multirange, + int8multirange, + nummultirange, + tsmultirange_int, + tsmultirange_float, + tstzmultirange_int, + tstzmultirange_float, + datemultirange, ) where @@ -75,6 +95,7 @@ import qualified Data.Text.Lazy as L import qualified PostgreSQL.Binary.Encoding.Builders as B import PostgreSQL.Binary.Prelude hiding (bool, length) +import qualified PostgreSQL.Binary.Range as S type Encoding = C.Builder @@ -372,3 +393,71 @@ nullField :: Word32 -> Composite nullField oid = Composite 1 (B.int4_word32 oid <> B.null4) + +-- * Range + +{-# INLINE int4range #-} +int4range :: S.Range Int32 -> Encoding +int4range = B.range B.int4_int32 + +{-# INLINE int8range #-} +int8range :: S.Range Int64 -> Encoding +int8range = B.range B.int8_int64 + +{-# INLINE numrange #-} +numrange :: S.Range Scientific -> Encoding +numrange = B.range B.numeric + +{-# INLINE tsrange_int #-} +tsrange_int :: S.Range LocalTime -> Encoding +tsrange_int = B.range B.timestamp_int + +{-# INLINE tsrange_float #-} +tsrange_float :: S.Range LocalTime -> Encoding +tsrange_float = B.range B.timestamp_float + +{-# INLINE tstzrange_int #-} +tstzrange_int :: S.Range UTCTime -> Encoding +tstzrange_int = B.range B.timestamptz_int + +{-# INLINE tstzrange_float #-} +tstzrange_float :: S.Range UTCTime -> Encoding +tstzrange_float = B.range B.timestamptz_float + +{-# INLINE daterange #-} +daterange :: S.Range Day -> Encoding +daterange = B.range B.date + +-- * Multirange + +{-# INLINE int4multirange #-} +int4multirange :: S.Multirange Int32 -> Encoding +int4multirange = B.multirange B.int4_int32 + +{-# INLINE int8multirange #-} +int8multirange :: S.Multirange Int64 -> Encoding +int8multirange = B.multirange B.int8_int64 + +{-# INLINE nummultirange #-} +nummultirange :: S.Multirange Scientific -> Encoding +nummultirange = B.multirange B.numeric + +{-# INLINE tsmultirange_int #-} +tsmultirange_int :: S.Multirange LocalTime -> Encoding +tsmultirange_int = B.multirange B.timestamp_int + +{-# INLINE tsmultirange_float #-} +tsmultirange_float :: S.Multirange LocalTime -> Encoding +tsmultirange_float = B.multirange B.timestamp_float + +{-# INLINE tstzmultirange_int #-} +tstzmultirange_int :: S.Multirange UTCTime -> Encoding +tstzmultirange_int = B.multirange B.timestamptz_int + +{-# INLINE tstzmultirange_float #-} +tstzmultirange_float :: S.Multirange UTCTime -> Encoding +tstzmultirange_float = B.multirange B.timestamptz_float + +{-# INLINE datemultirange #-} +datemultirange :: S.Multirange Day -> Encoding +datemultirange = B.multirange B.date diff --git a/library/PostgreSQL/Binary/Encoding/Builders.hs b/library/PostgreSQL/Binary/Encoding/Builders.hs --- a/library/PostgreSQL/Binary/Encoding/Builders.hs +++ b/library/PostgreSQL/Binary/Encoding/Builders.hs @@ -19,6 +19,7 @@ import qualified PostgreSQL.Binary.Numeric as C import PostgreSQL.Binary.Prelude hiding (bool) import qualified PostgreSQL.Binary.Prelude as B +import qualified PostgreSQL.Binary.Range as S import qualified PostgreSQL.Binary.Time as O -- * Helpers @@ -463,3 +464,24 @@ hStore_map input = int4_int (Q.size input) <> Q.foldlWithKey' (\payload key value -> payload <> hStoreRow key value) mempty input + +{-# INLINE range #-} +range :: (a -> Builder) -> S.Range a -> Builder +range builder r = + case r of + S.Empty -> word8 0x01 + S.Range S.Inf S.Inf -> word8 0x18 + S.Range (S.Excl l) (S.Excl r) -> word8 0x00 <> sized (builder l) <> sized (builder r) + S.Range (S.Incl l) (S.Excl r) -> word8 0x02 <> sized (builder l) <> sized (builder r) + S.Range (S.Excl l) (S.Incl r) -> word8 0x04 <> sized (builder l) <> sized (builder r) + S.Range (S.Incl l) (S.Incl r) -> word8 0x06 <> sized (builder l) <> sized (builder r) + S.Range (S.Excl l) S.Inf -> word8 0x10 <> sized (builder l) + S.Range (S.Incl l) S.Inf -> word8 0x12 <> sized (builder l) + S.Range S.Inf (S.Excl r) -> word8 0x08 <> sized (builder r) + S.Range S.Inf (S.Incl r) -> word8 0x0C <> sized (builder r) + +{-# INLINE multirange #-} +multirange :: (a -> Builder) -> S.Multirange a -> Builder +multirange builder ranges = + int4_int (fromIntegral (length ranges)) + <> foldMap (sized . range builder) ranges diff --git a/library/PostgreSQL/Binary/Prelude.hs b/library/PostgreSQL/Binary/Prelude.hs --- a/library/PostgreSQL/Binary/Prelude.hs +++ b/library/PostgreSQL/Binary/Prelude.hs @@ -42,7 +42,7 @@ import Data.HashMap.Strict as Exports (HashMap) import Data.IORef as Exports import Data.Int as Exports -import Data.Ix as Exports +import Data.Ix as Exports hiding (range) import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Map.Strict as Exports (Map) diff --git a/library/PostgreSQL/Binary/Range.hs b/library/PostgreSQL/Binary/Range.hs new file mode 100644 --- /dev/null +++ b/library/PostgreSQL/Binary/Range.hs @@ -0,0 +1,11 @@ +module PostgreSQL.Binary.Range where + +import PostgreSQL.Binary.Prelude + +data Range a = Empty | Range !(Bound a) !(Bound a) + deriving (Eq, Show, Ord, Generic) + +data Bound a = Incl !a | Excl !a | Inf + deriving (Eq, Show, Ord, Generic) + +type Multirange a = [Range a] diff --git a/postgresql-binary.cabal b/postgresql-binary.cabal --- a/postgresql-binary.cabal +++ b/postgresql-binary.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-binary -version: 0.14.1 +version: 0.14.2 synopsis: Encoders and decoders for the PostgreSQL's binary format description: An API for dealing with PostgreSQL's binary data format. @@ -72,6 +72,7 @@ exposed-modules: PostgreSQL.Binary.Decoding PostgreSQL.Binary.Encoding + PostgreSQL.Binary.Range other-modules: PostgreSQL.Binary.BuilderPrim diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -8,11 +8,12 @@ import qualified Main.Gens as Gens import qualified Main.IO as IO import qualified Main.PTI as PTI -import Main.Prelude hiding (isLeft, isRight, select) +import Main.Prelude hiding (empty, isLeft, isRight, select) import qualified Main.Properties as Properties import qualified Main.TextEncoder as TextEncoder import qualified PostgreSQL.Binary.Decoding as B import qualified PostgreSQL.Binary.Encoding as A +import qualified PostgreSQL.Binary.Range as S import Test.Tasty import Test.Tasty.HUnit as HUnit import Test.Tasty.QuickCheck as QuickCheck @@ -190,7 +191,171 @@ $ B.dimensionArray replicateM $ B.valueArray $ B.text_strict - in arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder + in arrayRoundtrip (Gens.array3 Gens.text) pti encoder decoder, + select "select ('[10, 20]' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) (S.Excl 21)), + select "select ('[10, 20)' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) (S.Excl 20)), + select "select ('(10, 20]' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) (S.Excl 21)), + select "select ('(10, 20)' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) (S.Excl 20)), + select "select ('[,20]' :: int4range)" (const B.int4range) (S.Range S.Inf (S.Excl 21)), + select "select ('[,20)' :: int4range)" (const B.int4range) (S.Range S.Inf (S.Excl 20)), + select "select ('[10,]' :: int4range)" (const B.int4range) (S.Range (S.Incl 10) S.Inf), + select "select ('(10,]' :: int4range)" (const B.int4range) (S.Range (S.Incl 11) S.Inf), + select "select ('(,)' :: int4range)" (const B.int4range) (S.Range S.Inf S.Inf), + select "select ('empty' :: int4range)" (const B.int4range) S.Empty, + HUnit.testCase "int4range encoder: [10, 20]" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Incl 10) (S.Incl 20) + normalized = + S.Range (S.Incl 10) (S.Excl 21) + in HUnit.assertEqual "" (Right normalized) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: [10, 20)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Incl 10) (S.Excl 20) + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (10, 20]" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Excl 10) (S.Incl 20) + normalized = + S.Range (S.Incl 11) (S.Excl 21) + in HUnit.assertEqual "" (Right normalized) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (10, 20)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Excl 10) (S.Excl 20) + normalized = + S.Range (S.Incl 11) (S.Excl 20) + in HUnit.assertEqual "" (Right normalized) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: [10,)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Incl 10) S.Inf + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (10,)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range (S.Excl 10) S.Inf + normalized = + S.Range (S.Incl 11) S.Inf + in HUnit.assertEqual "" (Right normalized) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (,20]" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range S.Inf (S.Incl 20) + normalized = + S.Range S.Inf (S.Excl 21) + in HUnit.assertEqual "" (Right normalized) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (,20)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range S.Inf (S.Excl 20) + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: empty" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Empty + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int4range encoder: (,)" + $ let pti = + PTI.int4range + encoder = + (const A.int4range) + decoder = + (const B.int4range) + value = + S.Range S.Inf S.Inf + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + select "select ('{[10, 20], [30, 40]}' :: int4multirange)" (const $ B.int4multirange) [S.Range (S.Incl 10) (S.Excl 21), S.Range (S.Incl 30) (S.Excl 41)], + HUnit.testCase "int4multirange encoder: {[10,20), [30,40)}" + $ let pti = + PTI.int4multirange + encoder = + (const A.int4multirange) + decoder = + (const B.int4multirange) + value = + [S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)] + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "int8multirange encoder: {[10,20), [30,40)}" + $ let pti = + PTI.int8multirange + encoder = + (const A.int8multirange) + decoder = + (const B.int8multirange) + value = + [S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)] + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value, + HUnit.testCase "nummultirange encoder: {[10,20), [30,40)}" + $ let pti = + PTI.nummultirange + encoder = + (const A.nummultirange) + decoder = + (const B.nummultirange) + value = + [S.Range (S.Incl 10) (S.Excl 20), S.Range (S.Incl 30) (S.Excl 40)] + in HUnit.assertEqual "" (Right value) + =<< IO.roundtrip (PTI.oidPQ (PTI.ptiOID pti)) encoder decoder value ] textual :: TestTree diff --git a/tasty/Main/PTI.hs b/tasty/Main/PTI.hs --- a/tasty/Main/PTI.hs +++ b/tasty/Main/PTI.hs @@ -61,6 +61,9 @@ daterange :: PTI daterange = mkPTI 3912 (Just 3913) +datemultirange :: PTI +datemultirange = mkPTI 4535 (Just 6155) + float4 :: PTI float4 = mkPTI 700 (Just 1021) @@ -85,12 +88,18 @@ int4range :: PTI int4range = mkPTI 3904 (Just 3905) +int4multirange :: PTI +int4multirange = mkPTI 4451 (Just 6150) + int8 :: PTI int8 = mkPTI 20 (Just 1016) int8range :: PTI int8range = mkPTI 3926 (Just 3927) +int8multirange :: PTI +int8multirange = mkPTI 4536 (Just 6157) + interval :: PTI interval = mkPTI 1186 (Just 1187) @@ -121,6 +130,9 @@ numrange :: PTI numrange = mkPTI 3906 (Just 3907) +nummultirange :: PTI +nummultirange = mkPTI 4532 (Just 6151) + oid :: PTI oid = mkPTI 26 (Just 1028) @@ -196,8 +208,14 @@ tsrange :: PTI tsrange = mkPTI 3908 (Just 3909) +tsmultirange :: PTI +tsmultirange = mkPTI 4533 (Just 6152) + tstzrange :: PTI tstzrange = mkPTI 3910 (Just 3911) + +tstzmultirange :: PTI +tstzmultirange = mkPTI 4534 (Just 6153) tsvector :: PTI tsvector = mkPTI 3614 (Just 3643)