12e43e4 · typeable/postgresql-simple

git.iko.soy/typeable/postgresql-simple

on master help sign in

Handle NaN and ±Infinity

12e43e4Leon P Smith12 years ago

src/Database/PostgreSQL/Simple/FromField.hs+19−4

compare with master

unifiedsplit

@@ -104,7 +104,7 @@ module Database.PostgreSQL.Simple.FromField

104

105#include "MachDeps.h"

106

107−import Control.Applicative ( (<|>), (<$>), pure )

107+import Control.Applicative ( (<|>), (<$>), pure, (*>) )

108import Control.Concurrent.MVar (MVar, newMVar)

109import Control.Exception (Exception)

110import qualified Data.Aeson as JSON

@@ -138,6 +138,7 @@ import qualified Data.Text.Lazy as LT

138import Data.UUID (UUID)

139import qualified Data.UUID as UUID

140import Data.Scientific (Scientific)

141+import GHC.Real (infinity, notANumber)

141

142

142-- | Exception thrown if conversion from a SQL value to a Haskell

143-- | Exception thrown if conversion from a SQL value to a Haskell

143-- value fails.

144-- value fails.

@@ -314,18 +315,18 @@ instance FromField Integer where

314-- | int2, float4 (Uses attoparsec's 'double' routine, for

315-- | int2, float4 (Uses attoparsec's 'double' routine, for

315-- better accuracy convert to 'Scientific' or 'Rational' first)

316-- better accuracy convert to 'Scientific' or 'Rational' first)

316instance FromField Float where

317instance FromField Float where

317− fromField = atto ok (realToFrac <$> double)

318+ fromField = atto ok (realToFrac <$> pg_double)

318 where ok = $(mkCompats [TI.float4,TI.int2])

319 where ok = $(mkCompats [TI.float4,TI.int2])

319

320

320-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for

321-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for

321-- better accuracy convert to 'Scientific' or 'Rational' first)

322-- better accuracy convert to 'Scientific' or 'Rational' first)

322instance FromField Double where

323instance FromField Double where

323− fromField = atto ok double

324+ fromField = atto ok pg_double

324 where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])

325 where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])

325

326

326-- | int2, int4, float4, float8, numeric

327-- | int2, int4, float4, float8, numeric

327instance FromField (Ratio Integer) where

328instance FromField (Ratio Integer) where

328− fromField = atto ok rational

329+ fromField = atto ok pg_rational

329 where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])

330 where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.numeric])

330

331

331-- | int2, int4, float4, float8, numeric

332-- | int2, int4, float4, float8, numeric

@@ -336,6 +337,20 @@ instance FromField Scientific where

336unBinary :: Binary t -> t

337unBinary :: Binary t -> t

337unBinary (Binary x) = x

338unBinary (Binary x) = x

338

339

340+pg_double :: Parser Double

341+pg_double

342+ = (string "NaN" *> pure ( 0 / 0))

343+ <|> (string "Infinity" *> pure ( 1 / 0))

344+ <|> (string "-Infinity" *> pure (-1 / 0))

345+ <|> double

346+

347+pg_rational :: Parser Rational

348+pg_rational

349+ = (string "NaN" *> pure notANumber )

350+ <|> (string "Infinity" *> pure infinity )

351+ <|> (string "-Infinity" *> pure (-infinity))

352+ <|> rational

353+

339-- | bytea, name, text, \"char\", bpchar, varchar, unknown

354-- | bytea, name, text, \"char\", bpchar, varchar, unknown

340instance FromField SB.ByteString where

355instance FromField SB.ByteString where

341 fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)

356 fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)

test/Main.hs+11

@@ -43,6 +43,7 @@ tests =

43 , TestLabel "Unicode" . testUnicode

44 , TestLabel "Values" . testValues

45 , TestLabel "Copy" . testCopy

46+ , TestLabel "Double" . testDouble

46 ]

47 ]

48testBytea :: TestEnv -> Test

49testBytea :: TestEnv -> Test

@@ -306,6 +307,16 @@ testCopy TestEnv{..} = TestCase $ do

306 CopyOutDone _ -> return rows

307 CopyOutDone _ -> return rows

307 CopyOutRow row -> loop (row:rows)

308 CopyOutRow row -> loop (row:rows)

308

309

310+testDouble :: TestEnv -> Test

311+testDouble TestEnv{..} = TestCase $ do

312+ [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"

313+ assertBool "expected NaN" (isNaN x)

314+ [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"

315+ x @?= (1 / 0)

316+ [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8"

317+ x @?= (-1 / 0)

318+

319+

309data TestException

320data TestException

310 = TestException

321 = TestException

311 deriving (Eq, Show, Typeable)

322 deriving (Eq, Show, Typeable)