54d2f03 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

range binary

54d2f03Eitan Chatav7 years ago

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs+42−25

compare with dev

unifiedsplit

@@ -58,11 +58,12 @@ module Squeal.PostgreSQL.Expression.Range

58 , rangeMerge

59 ) where

61−import Control.Applicative

62import BinaryParser

61import BinaryParser

63import ByteString.StrictBuilder

62import ByteString.StrictBuilder

63+import Data.Bits

64import qualified GHC.Generics as GHC

65import qualified Generics.SOP as SOP

66+import qualified PostgreSQL.Binary.Decoding as Decoding

67import Squeal.PostgreSQL.Binary

68import Squeal.PostgreSQL.Binary

68import Squeal.PostgreSQL.Expression

69import Squeal.PostgreSQL.Expression

@@ -111,33 +112,49 @@ data Range x = Empty | NonEmpty (Bound x) (Bound x)

111 , Functor, Foldable, Traversable )

112 , Functor, Foldable, Traversable )

112 deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

113 deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

113type instance PG (Range x) = 'PGrange (PG x)

114type instance PG (Range x) = 'PGrange (PG x)

114−-- https://github.com/postgres/postgres/blob/8255c7a5eeba8f1a38b7a431c04909bde4f5e67d/src/backend/utils/adt/rangetypes.c

115instance ToParam x pg => ToParam (Range x) ('PGrange pg) where

116− toParam = \case

116+ toParam rng = K $

117− Empty -> K (bytes "\'empty\'")

117+ word8 (setFlags rng 0) <>

118− NonEmpty l u -> K $ mconcat

118+ case rng of

119− [bytes (bra l), arg l, utf8Char ',', arg u, bytes (ket u)]

119+ Empty -> mempty

120+ NonEmpty lower upper -> putBound lower <> putBound upper

120 where

121 where

121− arg = \case

122+ putBound = \case

122− Infinite -> ""

123+ Infinite -> mempty

123− Closed x -> unK (toParam @x @pg x)

124+ Closed value -> putValue (unK (toParam @x @pg value))

124− Open x -> unK (toParam @x @pg x)

125+ Open value -> putValue (unK (toParam @x @pg value))

125− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("

126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value

126− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"

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

127instance FromValue pg y => FromValue ('PGrange pg) (Range y) where

139instance FromValue pg y => FromValue ('PGrange pg) (Range y) where

128− fromValue =

140+ fromValue = do

129− Empty <$ unitOfBytes "\'empty\'" <|> do

141+ flag <- byte

130− boundL <- boundLOpen <|> boundLClosed <|> boundLInfinite

142+ if testBit flag 0 then return Empty else do

131− unitOfBytes ","

143+ lower <-

132− boundR <- boundROpen <|> boundRClosed <|> boundRInfinite

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

133− return $ NonEmpty boundL boundR

157+ return $ NonEmpty lower upper

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 ")"

141

158

142(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x

159(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x

143infix 4 <=..<=, <..<, <=..<, <..<=

160infix 4 <=..<=, <..<, <=..<, <..<=

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1

@@ -432,7 +432,7 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

432 Just prepResult -> okResult_ prepResult

433 results <- for list $ \ params -> do

434 let

435− toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

435+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

436 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

437 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

438 case resultMaybe of

squeal-postgresql/test/Property.hs−3

@@ -9,7 +9,6 @@

9module Property (propertyTests) where

11import Control.Monad.Trans

12−import Data.Int (Int32)

13import Data.ByteString (ByteString)

12import Data.ByteString (ByteString)

14import Data.Scientific (fromFloatDigits)

13import Data.Scientific (fromFloatDigits)

15import Squeal.PostgreSQL hiding (check, defaultMain)

14import Squeal.PostgreSQL hiding (check, defaultMain)

@@ -27,11 +26,9 @@ propertyTests = Main.defaultMain

27 , roundtrip numeric (scientific (Range.exponentialFloatFrom 0 (-1E9) 1E9))

26 , roundtrip numeric (scientific (Range.exponentialFloatFrom 0 (-1E9) 1E9))

28 , roundtrip float4 (Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9))

27 , roundtrip float4 (Gen.float (Range.exponentialFloatFrom 0 (-1E9) 1E9))

29 , roundtrip float8 (Gen.double (Range.exponentialFloatFrom 0 (-1E308) 1E308))

28 , roundtrip float8 (Gen.double (Range.exponentialFloatFrom 0 (-1E308) 1E308))

30− , roundtrip int4range gen_int4range

31 ]

29 ]

32 where

30 where

33 scientific = fmap fromFloatDigits . Gen.float

31 scientific = fmap fromFloatDigits . Gen.float

34− gen_int4range = Gen.constant (Empty :: Range Int32)

36connectionString :: ByteString

33connectionString :: ByteString

37connectionString = "host=localhost port=5432 dbname=exampledb"

34connectionString = "host=localhost port=5432 dbname=exampledb"