diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index e663624..ef203ba 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -21,6 +21,8 @@ module Database.PostgreSQL.Simple.ToField , ToField(..) , toJSONField , inQuotes + , inParens + , parenNegatives ) where import Control.Applicative (Const(Const)) @@ -32,6 +34,7 @@ import Data.ByteString.Builder , wordDec, word8Dec, word16Dec, word32Dec, word64Dec , floatDec, doubleDec ) +import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) @@ -51,7 +54,6 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Builder as LT import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID import Data.Vector (Vector) @@ -59,7 +61,6 @@ import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time import Data.Scientific (Scientific) -import Data.Text.Lazy.Builder.Scientific (scientificBuilder) import Foreign.C.Types (CUInt(..)) -- | How to render an element when substituting it into a query. @@ -137,65 +138,65 @@ instance ToField Bool where {-# INLINE toField #-} instance ToField Int8 where - toField = Plain . int8Dec + toField = Plain . parenNegatives int8Dec {-# INLINE toField #-} instance ToField Int16 where - toField = Plain . int16Dec + toField = Plain . parenNegatives int16Dec {-# INLINE toField #-} instance ToField Int32 where - toField = Plain . int32Dec + toField = Plain . parenNegatives int32Dec {-# INLINE toField #-} instance ToField Int where - toField = Plain . intDec + toField = Plain . parenNegatives intDec {-# INLINE toField #-} instance ToField Int64 where - toField = Plain . int64Dec + toField = Plain . parenNegatives int64Dec {-# INLINE toField #-} instance ToField Integer where - toField = Plain . integerDec + toField = Plain . parenNegatives integerDec {-# INLINE toField #-} instance ToField Word8 where - toField = Plain . word8Dec + toField = Plain . parenNegatives word8Dec {-# INLINE toField #-} instance ToField Word16 where - toField = Plain . word16Dec + toField = Plain . parenNegatives word16Dec {-# INLINE toField #-} instance ToField Word32 where - toField = Plain . word32Dec + toField = Plain . parenNegatives word32Dec {-# INLINE toField #-} instance ToField Word where - toField = Plain . wordDec + toField = Plain . parenNegatives wordDec {-# INLINE toField #-} instance ToField Word64 where - toField = Plain . word64Dec + toField = Plain . parenNegatives word64Dec {-# INLINE toField #-} instance ToField PQ.Oid where - toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x + toField = Plain . \(PQ.Oid (CUInt x)) -> parenNegatives word32Dec x {-# INLINE toField #-} instance ToField Float where toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v)) - | otherwise = Plain (floatDec v) + | otherwise = Plain (parenNegatives floatDec v) {-# INLINE toField #-} instance ToField Double where toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v)) - | otherwise = Plain (doubleDec v) + | otherwise = Plain (parenNegatives doubleDec v) {-# INLINE toField #-} instance ToField Scientific where - toField x = toField (LT.toLazyText (scientificBuilder x)) + toField = Plain . parenNegatives scientificBuilder {-# INLINE toField #-} instance ToField (Binary SB.ByteString) where @@ -329,6 +330,26 @@ inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = char8 '\'' +-- | Surround a string with parentheses: \"@( )@\". +-- +-- This function /does not/ perform any other escaping. +inParens :: Builder -> Builder +inParens b = char8 '(' `mappend` b `mappend` char8 ')' + +-- | If @n@ is negative, surround its rendered value in parentheses: \"@(-3)@\". +-- +-- This is necessary because in PostgreSQL, @-@ is a unary operator that has +-- lower precedence than the @::@ operator, and that can cause problems at the +-- edge of allowed ranges. +-- +-- For example, @-32768::int2@ is parsed as @-(32768::int2)@, which throws an +-- "out of range" error, even though @(-32768)::int2@ is accepted. +-- +-- For types with signed zeros, @-0@ is not parenthesized. +parenNegatives :: (Num a, Ord a) => (a -> Builder) -> a -> Builder +parenNegatives f n | n < 0 = inParens (f n) + | otherwise = f n + interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as {-# INLINE interleaveFoldr #-} diff --git a/test/Main.hs b/test/Main.hs index 32eb230..df3209e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -86,6 +86,7 @@ tests env = testGroup "tests" , testCase "3-ary generic" . testGeneric3 , testCase "Timeout" . testTimeout , testCase "Exceptions" . testExceptions + , testCase "Paren negatives" . testParenNegatives ] testBytea :: TestEnv -> TestTree @@ -536,6 +537,19 @@ testDouble TestEnv{..} = do [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8" x @?= (-1 / 0) +testParenNegatives :: TestEnv -> Assertion +testParenNegatives TestEnv{..} = do + [Only (x :: Int)] <- query conn "SELECT ?::int2" (Only (-32768 :: Int)) + x @?= -32768 + [Only (x :: Int)] <- query conn "SELECT ?::int2" (Only (-32768.4 :: Double)) + x @?= -32768 + [(x :: Int, y :: Int)] <- + query conn "SELECT * FROM ? tbl" + (Only $ Values ["int2", "int2"] + [(-32768 :: Integer, -32768.4 :: Float)] + ) + x @?= -32768 + y @?= -32768 testGeneric1 :: TestEnv -> Assertion testGeneric1 TestEnv{..} = do