Implement FromField Float and FromField Double

lib/Database/PostgreSQL/Opium/FromField.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Database.PostgreSQL.Opium.FromField
@@ -8,13 +9,18 @@ module Database.PostgreSQL.Opium.FromField
 
 import Data.Attoparsec.Text
   ( Parser
+  , choice
   , decimal
+  , double
   , parseOnly
   , signed
+  , string
   , takeText
   )
+import Data.Functor (($>))
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (Oid)
+import GHC.Float (double2Float)
 
 import qualified Data.Text as Text
 import qualified Database.PostgreSQL.Opium.Oid as Oid
@@ -47,11 +53,6 @@ fromParser validOid parser oid field
 class FromField a where
   fromField :: Oid -> Text -> Either FieldError a
 
-instance FromField Int where
-  fromField = fromParser
-    (Oid.smallint \/ Oid.integer \/ Oid.bigint)
-    (signed decimal)
-
 instance FromField Text where
   fromField = fromParser
     (Oid.text \/ Oid.character \/ Oid.characterVarying)
@@ -59,3 +60,28 @@ instance FromField Text where
 
 instance FromField String where
   fromField oid text = Text.unpack <$> fromField oid text
+
+instance FromField Int where
+  fromField = fromParser
+    (Oid.smallint \/ Oid.integer \/ Oid.bigint)
+    (signed decimal)
+
+floatParser :: Parser Double
+floatParser = choice
+  [ string "NaN" $> nan
+  , signed (string "Infinity" $> infinity)
+  , double
+  ]
+  where
+    nan = 0 / 0
+    infinity = 1 / 0
+
+instance FromField Float where
+  fromField = fromParser
+    Oid.real
+    (fmap double2Float floatParser)
+
+instance FromField Double where
+  fromField = fromParser
+    (Oid.real \/ Oid.doublePrecision)
+    floatParser

lib/Database/PostgreSQL/Opium/Oid.hs

@@ -5,6 +5,17 @@ import Database.PostgreSQL.LibPQ (Oid (..))
 eq :: Eq a => a -> a -> Bool
 eq = (==)
 
+-- string types
+
+text :: Oid -> Bool
+text = eq $ Oid 25
+
+character :: Oid -> Bool
+character = eq $ Oid 1042
+
+characterVarying :: Oid -> Bool
+characterVarying = eq $ Oid 1043
+
 -- integer types
 
 -- | 16-bit integer
@@ -19,13 +30,12 @@ integer = eq $ Oid 23
 bigint :: Oid -> Bool
 bigint = eq $ Oid 20
 
--- string types
+-- floating point types
 
-text :: Oid -> Bool
-text = eq $ Oid 25
+-- | 32-bit IEEE float
+real :: Oid -> Bool
+real = eq $ Oid 700
 
-character :: Oid -> Bool
-character = eq $ Oid 1042
-
-characterVarying :: Oid -> Bool
-characterVarying = eq $ Oid 1043
+-- | 64-bit IEEE float
+doublePrecision :: Oid -> Bool
+doublePrecision = eq $ Oid 701

test/Database/PostgreSQL/Opium/FromFieldSpec.hs

@@ -8,63 +8,120 @@ import Data.Text (Text)
 import Database.PostgreSQL.LibPQ (Connection)
 import Database.PostgreSQL.Opium (FromRow)
 import GHC.Generics (Generic)
-import Test.Hspec (SpecWith, describe, it, shouldBe)
+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)
 
 import qualified Database.PostgreSQL.Opium as Opium
 
-newtype SingleInt = SingleInt
+newtype AnInt = AnInt
   { int :: Int
   } deriving (Eq, Generic, Show)
 
-instance FromRow SingleInt where
+instance FromRow AnInt where
 
-newtype SingleText = SingleText
+newtype AText = AText
   { text :: Text
   } deriving (Eq, Generic, Show)
 
-instance FromRow SingleText where
+instance FromRow AText where
 
-newtype SingleString = SingleString
+newtype AString = AString
   { string :: String
   } deriving (Eq, Generic, Show)
 
-instance FromRow SingleString where
+instance FromRow AString where
+
+newtype AFloat = AFloat
+  { float :: Float
+  } deriving (Eq, Generic, Show)
+
+instance FromRow AFloat
+
+newtype ADouble = ADouble
+  { double :: Double
+  } deriving (Eq, Generic, Show)
+
+instance FromRow ADouble where
 
 shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> ByteString -> [a] -> IO ()
 shouldFetch conn query expectedRows = do
   actualRows <- Opium.fetch_ conn query
   actualRows `shouldBe` Right expectedRows
 
+(/\) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+p /\ q = \x -> p x && q x
+
 spec :: SpecWith Connection
 spec = do
   describe "FromField Int" $ do
     it "Decodes smallint" $ \conn -> do
-      shouldFetch conn "SELECT 42::SMALLINT AS int" [SingleInt 42]
+      shouldFetch conn "SELECT 42::SMALLINT AS int" [AnInt 42]
 
     it "Decodes integer" $ \conn -> do
-      shouldFetch conn "SELECT 42::INTEGER AS int" [SingleInt 42]
+      shouldFetch conn "SELECT 42::INTEGER AS int" [AnInt 42]
 
     it "Decodes bigint" $ \conn -> do
-      shouldFetch conn "SELECT 42::BIGINT AS int" [SingleInt 42]
+      shouldFetch conn "SELECT 42::BIGINT AS int" [AnInt 42]
 
   describe "FromField Text" $ do
     it "Decodes text" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::TEXT AS text" [SingleText "Hello, World!"]
+      shouldFetch conn "SELECT 'Hello, World!'::TEXT AS text" [AText "Hello, World!"]
 
     it "Decodes character" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS text" [SingleText "Hello, Wor"]
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS text" [SingleText "Hello, World!       "]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS text" [AText "Hello, Wor"]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS text" [AText "Hello, World!       "]
 
     it "Decodes character varying" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS text" [SingleText "Hello, World!"]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS text" [AText "Hello, World!"]
 
   describe "FromField String" $ do
     it "Decodes text" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::TEXT AS string" [SingleString "Hello, World!"]
+      shouldFetch conn "SELECT 'Hello, World!'::TEXT AS string" [AString "Hello, World!"]
 
     it "Decodes character" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS string" [SingleString "Hello, Wor"]
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS string" [SingleString "Hello, World!       "]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(10) AS string" [AString "Hello, Wor"]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER(20) AS string" [AString "Hello, World!       "]
 
     it "Decodes character varying" $ \conn -> do
-      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS string" [SingleString "Hello, World!"]
+      shouldFetch conn "SELECT 'Hello, World!'::CHARACTER VARYING (20) AS string" [AString "Hello, World!"]
+
+  describe "FromField Float" $ do
+    it "Decodes real" $ \conn -> do
+      shouldFetch conn "SELECT 4.2::real AS float" [AFloat 4.2]
+
+    it "Decodes NaN::real" $ \conn -> do
+      Right [AFloat value] <- Opium.fetch_ conn "SELECT 'NaN'::real AS float"
+      value `shouldSatisfy` isNaN
+
+    it "Decodes Infinity::real" $ \conn -> do
+      Right [AFloat value] <- Opium.fetch_ conn "SELECT 'Infinity'::real AS float"
+      value `shouldSatisfy` (isInfinite /\ (> 0))
+
+    it "Decodes -Infinity::real" $ \conn -> do
+      Right [AFloat value] <- Opium.fetch_ conn "SELECT '-Infinity'::real AS float"
+      value `shouldSatisfy` (isInfinite /\ (< 0))
+
+  describe "FromField Double" $ do
+    it "Decodes double precision" $ \conn -> do
+      shouldFetch conn "SELECT 4.2::double precision AS double" [ADouble 4.2]
+
+    it "Decodes real" $ \conn -> do
+      shouldFetch conn "SELECT 4.2::real AS double" [ADouble 4.2]
+
+    it "Decodes NaN::double precision" $ \conn -> do
+      Right [ADouble value] <- Opium.fetch_ conn "SELECT 'NaN'::double precision AS double"
+      value `shouldSatisfy` isNaN
+
+    it "Decodes Infinity::double precision" $ \conn -> do
+      Right [ADouble value] <- Opium.fetch_ conn "SELECT 'Infinity'::double precision AS double"
+      value `shouldSatisfy` (isInfinite /\ (> 0))
+
+    it "Decodes -Infinity::double precision" $ \conn -> do
+      Right [ADouble value] <- Opium.fetch_ conn "SELECT '-Infinity'::double precision AS double"
+      value `shouldSatisfy` (isInfinite /\ (< 0))
+
+    it "Decodes {inf,-inf}::double precision" $ \conn -> do
+      Right [ADouble value0] <- Opium.fetch_ conn "SELECT 'inf'::double precision AS double"
+      value0 `shouldSatisfy` (isInfinite /\ (> 0))
+
+      Right [ADouble value1] <- Opium.fetch_ conn "SELECT '-inf'::double precision AS double"
+      value1 `shouldSatisfy` (isInfinite /\ (< 0))