Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add doubleNonFinite for IEEE 754 floats #5

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add doubleNonFinite for IEEE 754 floats #5

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions hermes-json.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

18 changes: 18 additions & 0 deletions src/Data/Hermes.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,7 @@ module Data.Hermes
, bool
, char
, double
, doubleNonFinite
, int
, scientific
, string
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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
Comment on lines +532 to +538
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thanks for quickly developing this PR.

I noticed that it matches on the actual bytestring inside the JSON AST. This means that if the string is encoded e.g. using escape codes, it wouldn't parse. Granted, this is a very academic issue, but I thought it was worth pointing out.

For example, using Aeson:

ghci> decode @Double "\"\\u002dinf\""
Just (-Infinity)

But using this PR:

ghci> decodeEither personDecoder "{\"lol\": \"\\u002dinf\"}"
Left (InternalException (HError {path = "/lol", errorMsg = "Failed to parse Scientific: Failed reading: takeWhile1", docLocation = "\"\\u002dinf\"}", docDebug = "json_iterator [ depth : 2, structural : '\"', offset : 8', error : No error ]"}))
ghci> decodeEither personDecoder "{\"lol\": \"-inf\"}"
Right (Person (-Infinity))

I don't really mind too much, I think the PR is fine as is. I don't think it is likely that people will re-encode their Aeson JSON such that it uses escape codes for the non-finite IEEE 754 values.

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah that's the trick with get_raw_json_token, whereas get_string escapes the string but will generate an exception if the value isn't actually a string. I will see if I can address this without losing performance. Although I do agree not handling escaped strings for this particular decoder should not be a major problem.

{-# INLINE getDoubleNonFinite #-}

-- | Helper to work with a Double parsed from a Value.
withDouble :: (Double -> Decoder a) -> Value -> Decoder a
withDouble f = getDouble >=> f
Expand Down Expand Up @@ -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
Expand Down
32 changes: 31 additions & 1 deletion tests/test.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down