diff --git a/hermes-json.cabal b/hermes-json.cabal index b7edb39..30ef012 100644 --- a/hermes-json.cabal +++ b/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 diff --git a/src/Data/Hermes.hs b/src/Data/Hermes.hs index 13bf7ae..3b11182 100644 --- a/src/Data/Hermes.hs +++ b/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 diff --git a/tests/test.hs b/tests/test.hs index 558818b..9d5924a 100644 --- a/tests/test.hs +++ b/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