@@ -58,11 +58,12 @@ module Squeal.PostgreSQL.Expression.Range
5858 , rangeMerge
5959 ) where
6060
61−import Control.Applicative
6261import BinaryParser
6362import ByteString.StrictBuilder
63+import Data.Bits
6464import qualified GHC.Generics as GHC
6565import qualified Generics.SOP as SOP
66+import qualified PostgreSQL.Binary.Decoding as Decoding
6667
6768import Squeal.PostgreSQL.Binary
6869import Squeal.PostgreSQL.Expression
@@ -111,33 +112,49 @@ data Range x = Empty | NonEmpty (Bound x) (Bound x)
111112 , Functor, Foldable, Traversable )
112113 deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
113114type instance PG (Range x) = 'PGrange (PG x)
114−-- https://github.com/postgres/postgres/blob/8255c7a5eeba8f1a38b7a431c04909bde4f5e67d/src/backend/utils/adt/rangetypes.c
115115instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116− toParam = \case
117− Empty -> K (bytes "\'empty\'")
118− NonEmpty l u -> K $ mconcat
119− [bytes (bra l), arg l, utf8Char ',', arg u, bytes (ket u)]
116+ toParam rng = K $
117+ word8 (setFlags rng 0) <>
118+ case rng of
119+ Empty -> mempty
120+ NonEmpty lower upper -> putBound lower <> putBound upper
120121 where
121− arg = \case
122− Infinite -> ""
123− Closed x -> unK (toParam @x @pg x)
124− Open x -> unK (toParam @x @pg x)
125− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
126− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
122+ putBound = \case
123+ Infinite -> mempty
124+ Closed value -> putValue (unK (toParam @x @pg value))
125+ Open value -> putValue (unK (toParam @x @pg value))
126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value
127+ setFlags = \case
128+ Empty -> (`setBit` 0)
129+ NonEmpty lower upper ->
130+ setLowerFlags lower . setUpperFlags upper
131+ setLowerFlags = \case
132+ Infinite -> (`setBit` 3)
133+ Closed _ -> (`setBit` 1)
134+ Open _ -> id
135+ setUpperFlags = \case
136+ Infinite -> (`setBit` 4)
137+ Closed _ -> (`setBit` 2)
138+ Open _ -> id
127139instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
128− fromValue =
129− Empty <$ unitOfBytes "\'empty\'" <|> do
130− boundL <- boundLOpen <|> boundLClosed <|> boundLInfinite
131− unitOfBytes ","
132− boundR <- boundROpen <|> boundRClosed <|> boundRInfinite
133− return $ NonEmpty boundL boundR
134− where
135− boundLClosed = unitOfBytes "[" *> (Closed <$> fromValue @pg @y)
136− boundLOpen = unitOfBytes "(" *> (Open <$> fromValue @pg @y)
137− boundLInfinite = Infinite <$ unitOfBytes "("
138− boundRClosed = (Closed <$> fromValue @pg @y) <* unitOfBytes "]"
139− boundROpen = (Open <$> fromValue @pg @y) <* unitOfBytes ")"
140− boundRInfinite = Infinite <$ unitOfBytes ")"
140+ fromValue = do
141+ flag <- byte
142+ if testBit flag 0 then return Empty else do
143+ lower <-
144+ if testBit flag 3
145+ then return Infinite
146+ else do
147+ len <- sized 4 Decoding.int
148+ l <- sized len (fromValue @pg)
149+ return $ if testBit flag 1 then Closed l else Open l
150+ upper <-
151+ if testBit flag 4
152+ then return Infinite
153+ else do
154+ len <- sized 4 Decoding.int
155+ l <- sized len (fromValue @pg)
156+ return $ if testBit flag 2 then Closed l else Open l
157+ return $ NonEmpty lower upper
141158
142159(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
143160infix 4 <=..<=, <..<, <=..<, <..<=