Fixed an issue where Haskell Double and Float literals were implicitl…

…y converted to Postgres NUMERIC instead of `double precision` (fixes #700)
haskell-beam · Oct 17, 2024 · 7b3192d · 7b3192d
1 parent 8919ea3
commit 7b3192d
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 4 deletions.
diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs
@@ -100,7 +100,7 @@ import           Control.Monad.Free.Church
 import           Data.Aeson (Value, object, (.=))
 import           Data.Bits
 import           Data.ByteString (ByteString)
-import           Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString)
+import           Data.ByteString.Builder (Builder, doubleDec, floatDec, byteString, char8, toLazyByteString)
 import qualified Data.ByteString.Char8 as B
 import           Data.ByteString.Lazy.Char8 (toStrict)
 import qualified Data.ByteString.Lazy.Char8 as BL
@@ -1202,8 +1202,6 @@ instance DatabasePredicate PgHasEnum where
              sqlValueSyntax = defaultPgValueSyntax
 
 DEFAULT_SQL_SYNTAX(Bool)
-DEFAULT_SQL_SYNTAX(Double)
-DEFAULT_SQL_SYNTAX(Float)
 DEFAULT_SQL_SYNTAX(Int8)
 DEFAULT_SQL_SYNTAX(Int16)
 DEFAULT_SQL_SYNTAX(Int32)
@@ -1231,6 +1229,21 @@ DEFAULT_SQL_SYNTAX(Pg.LocalTimestamp)
 DEFAULT_SQL_SYNTAX(Pg.UTCTimestamp)
 DEFAULT_SQL_SYNTAX(Scientific)
 
+-- We have a 'manual' instance for Double and Float because the default value of a
+-- literal like "1.0" is NUMERIC, not DOUBLE. However, NUMERIC values are exact, 
+-- while DOUBLEs are inexact. This means that converting from SQL NUMERIC
+-- to Haskell Double is lossy.
+-- See #700
+instance HasSqlValueSyntax PgValueSyntax Float where
+  sqlValueSyntax v 
+    | isNaN v || isInfinite v = PgValueSyntax $ emit "'" <> emitBuilder (floatDec v) <> emit "'"
+    | otherwise               = PgValueSyntax $ emit "'" <> emitBuilder (floatDec v) <> emit "'::double precision"
+
+instance HasSqlValueSyntax PgValueSyntax Double where
+  sqlValueSyntax v 
+    | isNaN v || isInfinite v = PgValueSyntax $ emit "'" <> emitBuilder (doubleDec v) <> emit "'"
+    | otherwise               = PgValueSyntax $ emit "'" <> emitBuilder (doubleDec v) <> emit "'::double precision"
+
 instance HasSqlValueSyntax PgValueSyntax (CI T.Text) where
   sqlValueSyntax = sqlValueSyntax . CI.original
 instance HasSqlValueSyntax PgValueSyntax (CI TL.Text) where

diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/DataTypes.hs b/beam-postgres/test/Database/Beam/Postgres/Test/DataTypes.hs
@@ -21,7 +21,8 @@ tests :: IO ByteString -> TestTree
 tests postgresConn =
     testGroup "Data-type unit tests"
     [ jsonNulTest postgresConn
-    , errorOnSchemaMismatch postgresConn ]
+    , errorOnSchemaMismatch postgresConn
+    , errorOnLiteralDoubles postgresConn ]
 
 data JsonT f
     = JsonT
@@ -136,3 +137,20 @@ errorOnSchemaMismatch pgConn =
 
       assertBool "runInsertReturningList succeeded" didFail
       didFail @?= True
+
+-- | Regression test for <https://github.com/haskell-beam/beam/issues/700>
+errorOnLiteralDoubles :: IO ByteString -> TestTree
+errorOnLiteralDoubles pgConn =
+    testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ 
+    withTestPostgres "db_failures" pgConn $ \conn -> do
+      results <- runBeamPostgres conn $ 
+        runSelectReturningList $ 
+          select $ 
+            query
+
+      results @?= [(99 :: Int32, 1.0 :: Double)]
+
+    where
+      -- We need to provide a db for type-checking, but it will not be used
+      query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double)
+      query = pure (val_ 99, val_ 1.0)