Add doubleNonFinite for IEEE 754 floats

hermes-json.cabal

@@ -119,6 +119,7 @@ test-suite hermes-test
     text,
     hedgehog       >= 1.0.5 && < 1.1,
     tasty          >= 1.4.2 && < 1.5,
+    tasty-hunit    >= 0.10.0 && < 0.11,
     tasty-hedgehog >= 1.1.0 && < 1.2,
     time
 

src/Data/Hermes.hs

@@ -36,6 +36,7 @@ module Data.Hermes
   , bool
   , char
   , double
+  , doubleNonFinite
   , int
   , scientific
   , string
@@ -86,6 +87,7 @@ import qualified Data.Attoparsec.Text as AT
 import qualified Data.Attoparsec.Time as ATime
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Unsafe as Unsafe
 import qualified Data.DList as DList
 import           Data.Maybe (fromMaybe)
@@ -527,6 +529,15 @@ getDouble valPtr = withRunInIO $ \run ->
     liftIO $ peek ptr
 {-# INLINE getDouble #-}
 
+getDoubleNonFinite :: Value -> Decoder Double
+getDoubleNonFinite = withRawByteString $ \bs ->
+  case BSC.strip bs of
+    "\"+inf\"" -> pure $ 1/0
+    "\"-inf\"" -> pure $ (-1)/0
+    "null"     -> pure $ 0/0
+    _          -> Sci.toRealFloat <$> parseScientific bs
+{-# INLINE getDoubleNonFinite #-}
+
 -- | Helper to work with a Double parsed from a Value.
 withDouble :: (Double -> Decoder a) -> Value -> Decoder a
 withDouble f = getDouble >=> f
@@ -720,6 +731,13 @@ bool = getBool
 double :: Value -> Decoder Double
 double = getDouble
 
+-- | Parse an IEEE 754 floating point number into a Haskell Double.
+-- This follows the encoding convention used in the aeson library.
+-- If you do not need to handle non-finite floating point values
+-- then use `double` instead, it has better performance.
+doubleNonFinite :: Value -> Decoder Double
+doubleNonFinite = getDoubleNonFinite
+
 -- | Parse a Scientific from a Value.
 scientific :: Value -> Decoder Sci.Scientific
 scientific = withRawByteString parseScientific

tests/test.hs

@@ -5,8 +5,10 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
 
 import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -19,6 +21,7 @@ import           Hedgehog
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 import           Test.Tasty
+import           Test.Tasty.HUnit
 import           Test.Tasty.Hedgehog
 
 import           Data.Hermes
@@ -27,11 +30,14 @@ main :: IO ()
 main = defaultMain tests
 
 tests :: TestTree
-tests = testGroup "Tests" [properties]
+tests = testGroup "Tests" [properties, units]
 
 properties :: TestTree
 properties = testGroup "Properties" [rtProp, rtPropOptional, rtErrors]
 
+units :: TestTree
+units = testGroup "Units" [aesonIEEE754]
+
 rtProp :: TestTree
 rtProp = testProperty "Round Trip With Aeson.ToJSON" $
   withTests 1000 . property $ do
@@ -67,6 +73,30 @@ rtErrors = testProperty "Errors Should Not Break Referential Transparency" $
         d2 = decodeEither decodePerson p
     d1 === d2
 
+makeDummyObj :: A.ToJSON value => value -> BS.ByteString
+makeDummyObj v = "{ \"_\": " <> (BSL.toStrict . A.encode $ v) <> "}"
+
+dummyDecoder :: (Value -> Decoder a) -> Value -> Decoder a
+dummyDecoder d = withObject $ atKey "_" d
+
+aesonIEEE754 :: TestTree
+aesonIEEE754 = testGroup "Decodes IEEE 754 Floating Point"
+  [ testCase "Infinity" $
+      decodeEither (dummyDecoder doubleNonFinite) (makeDummyObj @Double (1/0))
+        @?= (Right (1/0))
+  , testCase "-Infinity" $
+      decodeEither (dummyDecoder doubleNonFinite) (makeDummyObj @Double ((-1)/0))
+        @?= (Right ((-1)/0))
+  , testCase "NaN" $
+      fmap isNaN
+        (decodeEither (dummyDecoder doubleNonFinite) (makeDummyObj @Double (0/0)))
+        @?= (Right True)
+  , testCase "null" $
+      fmap isNaN
+        (decodeEither (dummyDecoder doubleNonFinite) (makeDummyObj @(Maybe Double) Nothing))
+        @?= (Right True)
+  ]
+
 data Person =
   Person
     { _id           :: Text